diff --git a/.gitattributes b/.gitattributes index 04bbf50d38..ebbd25bf08 100644 --- a/.gitattributes +++ b/.gitattributes @@ -9757,6 +9757,56 @@ tests/test/cg/variants/tvarol94.pp svneol=native#text/plain tests/test/cg/variants/tvarol96.pp svneol=native#text/plain tests/test/dumpclass.pp svneol=native#text/plain tests/test/dumpmethods.pp svneol=native#text/plain +tests/test/jvm/JavaClass.java svneol=native#text/plain +tests/test/jvm/classlist.pp svneol=native#text/plain +tests/test/jvm/classmeth.pp svneol=native#text/plain +tests/test/jvm/forw.pp svneol=native#text/plain +tests/test/jvm/getbit.pp svneol=native#text/plain +tests/test/jvm/nested.pp svneol=native#text/plain +tests/test/jvm/outpara.pp svneol=native#text/plain +tests/test/jvm/sort.pp svneol=native#text/plain +tests/test/jvm/tabs.pp svneol=native#text/plain +tests/test/jvm/taddset.pp svneol=native#text/plain +tests/test/jvm/taddsetint.pp svneol=native#text/plain +tests/test/jvm/tarray2.pp svneol=native#text/plain +tests/test/jvm/tarray3.pp svneol=native#text/plain +tests/test/jvm/tbyte.pp svneol=native#text/plain +tests/test/jvm/tbytearrres.pp svneol=native#text/plain +tests/test/jvm/tclassproptest.pp svneol=native#text/plain +tests/test/jvm/tcnvstr1.pp svneol=native#text/plain +tests/test/jvm/tcnvstr3.pp svneol=native#text/plain +tests/test/jvm/tconst.pp svneol=native#text/plain +tests/test/jvm/tdefpara.pp svneol=native#text/plain +tests/test/jvm/tdynarrec.pp svneol=native#text/plain +tests/test/jvm/tenum.pp svneol=native#text/plain +tests/test/jvm/test.pp -text svneol=native#text/plain +tests/test/jvm/testall.bat -text svneol=native#application/x-bat +tests/test/jvm/testall.sh -text svneol=native#application/x-sh +tests/test/jvm/testansi.pp svneol=native#text/plain +tests/test/jvm/testintf.pp svneol=native#text/plain +tests/test/jvm/testshort.pp svneol=native#text/plain +tests/test/jvm/tformalpara.pp svneol=native#text/plain +tests/test/jvm/tint.pp svneol=native#text/plain +tests/test/jvm/tintstr.pp svneol=native#text/plain +tests/test/jvm/tnestproc.pp svneol=native#text/plain +tests/test/jvm/tprop.pp svneol=native#text/plain +tests/test/jvm/tprop2.pp svneol=native#text/plain +tests/test/jvm/tpvar.pp svneol=native#text/plain +tests/test/jvm/tpvardelphi.pp svneol=native#text/plain +tests/test/jvm/tpvarglobal.pp svneol=native#text/plain +tests/test/jvm/tpvarglobaldelphi.pp svneol=native#text/plain +tests/test/jvm/trange1.pp svneol=native#text/plain +tests/test/jvm/trange2.pp svneol=native#text/plain +tests/test/jvm/trange3.pp svneol=native#text/plain +tests/test/jvm/tset1.pp svneol=native#text/plain +tests/test/jvm/tset3.pp svneol=native#text/plain +tests/test/jvm/ttrig.pp svneol=native#text/plain +tests/test/jvm/ttrunc.pp svneol=native#text/plain +tests/test/jvm/tvarpara.pp svneol=native#text/plain +tests/test/jvm/tvirtclmeth.pp svneol=native#text/plain +tests/test/jvm/twith.pp svneol=native#text/plain +tests/test/jvm/uenum.pp svneol=native#text/plain +tests/test/jvm/unsupported.pp svneol=native#text/plain tests/test/lcpref.inc svneol=native#text/plain tests/test/library/testdll.pp svneol=native#text/plain tests/test/library/testdll2.pp svneol=native#text/plain diff --git a/tests/test/jvm/JavaClass.java b/tests/test/jvm/JavaClass.java new file mode 100644 index 0000000000..2274898aa2 --- /dev/null +++ b/tests/test/jvm/JavaClass.java @@ -0,0 +1,260 @@ +import org.freepascal.rtl.*; +import org.freepascal.test.*; + + +public class JavaClass +{ + +public static void main(String[] args) throws java.lang.Exception +{ + TMyClass t = new TMyClass(); + + tintfclass intfclass; + tintfclass2 intfclass2; + tinterface1 intf1; + tinterface3 intf3; + tinterface4 intf4; + Object obj = new trec(); + System.out.println(((trec)obj).a); + + // check referencing a nested class + tisclass1.tisclass1nested nestedclass = new tisclass1.tisclass1nested(); + + + System.out.println("t.test(10,8) should return 3: "+t.test(10,8)); + System.out.println("t.test(20,1) should return -1: "+t.test(20,1)); + t.setintfield(123); + System.out.println("t.getintfield should return 123: "+t.getintfield()); + t.setstaticbytefield((byte)42); + System.out.println("t.getstaticbytefield should return 42: "+t.getstaticbytefield()); + System.out.println("myrec.a should return 42: "+test.myrec.a); + System.out.println("myrec.b should return 1234: "+test.myrec.b); + System.out.println("TMyClass.rec.c should return 5678: "+TMyClass.rec.c); + System.out.println("test.tcl should return 4: "+test.tcl); + System.out.println("test.tcrec.a should return 1: "+test.tcrec.a); + System.out.println("test.tcrec.e should return 5: "+test.tcrec.e); + System.out.println("test.tcnestrec.r.d should return 4: "+test.tcnestrec.r.d); + System.out.println("test.tcnestrec.r.arr[1] should return 6: "+test.tcnestrec.arr[1]); + TMyClass.settestglobal(654321); + System.out.println("TMyClass.gettestglobal should return 654321: "+TMyClass.gettestglobal()); + System.out.println("TMyClass.staticmul3(3) should return 9: "+TMyClass.staticmul3(3)); + System.out.println("testset should return 0: "+test.testset()); + System.out.println("testloop should return 0: "+test.testloop()); + System.out.println("testfloat should return 0: "+test.testfloat()); + System.out.println("testint2real should return 0: "+test.testint2real()); + System.out.println("testcnvint1 should return 0: "+test.testcnvint1()); + System.out.println("TestCmpListOneShort should return 0: "+test.TestCmpListOneShort()); + System.out.println("TestCmpListTwoShort should return 0: "+test.TestCmpListTwoShort()); + System.out.println("TestCmpListOneWord should return 0: "+test.TestCmpListOneWord()); + System.out.println("TestCmpListTwoWord should return 0: "+test.TestCmpListTwoWord()); + System.out.println("TestCmpListRangesOneShort should return 0: "+test.TestCmpListRangesOneShort()); + System.out.println("TestCmpListRangesTwoShort should return 0: "+test.TestCmpListRangesTwoShort()); + System.out.println("TestCmpListRangesOneWord should return 0: "+test.TestCmpListRangesOneWord()); + System.out.println("TestCmpListRangesTwoWord should return 0: "+test.TestCmpListRangesTwoWord()); + System.out.println("TestCmpListRangesThreeWord should return 0: "+test.TestCmpListRangesThreeWord()); + System.out.println("TestCmpListOneInt64 should return 0: "+test.TestCmpListOneInt64()); + System.out.println("TestCmpListTwoInt64 should return 0: "+test.TestCmpListTwoInt64()); + System.out.println("TestCmpListThreeInt64 should return 0: "+test.TestCmpListThreeInt64()); + System.out.println("TestCmpListRangesOneInt64 should return 0: "+test.TestCmpListRangesOneInt64()); + System.out.println("TestCmpListRangesTwoInt64 should return 0: "+test.TestCmpListRangesTwoInt64()); + System.out.println("testsqr should return 0: "+test.testsqr()); + System.out.println("testtrunc should return 0: "+test.testtrunc()); + System.out.println("testdynarr should return 0: "+test.testdynarr()); + System.out.println("testdynarr2 should return 0: "+test.testdynarr2()); + System.out.println("testbitcastintfloat should return 0: "+test.testbitcastintfloat()); + System.out.println("testis should return 0: "+test.testis()); + System.out.println("testneg should return 0: "+test.testneg()); + System.out.println("testtry1 should return 0: "+test.testtry1()); + System.out.println("testtry2 should return 0: "+test.testtry2()); + System.out.println("testtryfinally1 should return 0: "+test.testtryfinally1()); + System.out.println("testtryfinally2 should return 0: "+test.testtryfinally2()); + System.out.println("testtryfinally3 should return 0: "+test.testtryfinally3()); + System.out.println("testsmallarr1 should return 0: "+test.testsmallarr1()); + System.out.println("testsmallarr2 should return 0: "+test.testsmallarr2()); + System.out.println("testsmallarr3 should return 0: "+test.testsmallarr3()); + System.out.println("testsmallarr4 should return 0: "+test.testsmallarr4()); + System.out.println("testopenarr1 should return 0: "+test.testopenarr1()); + System.out.println("testopenarr2 should return 0: "+test.testopenarr2()); + System.out.println("testopenarr3 should return 0: "+test.testopenarr3()); + System.out.println("testopendynarr should return 0: "+test.testopendynarr()); + System.out.println("testrec1 should return 0: "+test.testrec1()); + System.out.println("testrec2 should return 0: "+test.testrec2()); + System.out.println("testopenarr1rec should return 0: "+test.testopenarr1rec()); + System.out.println("test.unitintconst should be 3: "+test.unitintconst); + System.out.println("test.unitfloatconst should be 2.0: "+test.unitfloatconst); + System.out.println("test.unitdoubleconst should be 0.1: "+test.unitdoubleconst); + System.out.println("TMyclass.classintconst should be 4: "+TMyClass.classintconst); + System.out.println("TMyclass.classfloatconst should be 3.0: "+TMyClass.classfloatconst); + + System.out.println(); + + intfclass = new tintfclass(); + intf1 = intfclass; + intfclass2 = new tintfclass2(); + + System.out.println("intfclass.test(int) should return 10: "+intfclass.test(9)); + System.out.println("intf1.test(int) should return 10: "+intf1.test(9)); + System.out.println("intfclass.test(byte) should return 11: "+intfclass.test((byte)9)); + System.out.println("intfclass2.intf4test(int64) should return -2: "+intfclass2.intf4test((long)-12345*2-133)); + System.out.println("tinterface2.iconst should be 4: "+tinterface2.iconst); + + intfclass.Free(); + + System.out.println(" *** Note: string tests expect that Java source file is compiled with '-encoding utf-8' and test is run with '-Dfile.encoding=UTF-8'"); + System.out.println("testunicodestring should return ~ê∂êºîƒ~©¬ -- ê = \u00ea ⊗ = \u2297: "+test.testunicodestring()); + System.out.println(" equal: "+test.testunicodestring().equals("~ê∂êºîƒ~©¬")); + System.out.println("testunicodestring2 should return <\\\r\n\">: <"+test.testunicodestring2()+">"); + System.out.println(" equal: "+test.testunicodestring2().equals("\\\r\n\"")); + System.out.println("testunicodestring3 should return abcdef: "+test.testunicodestring3("abc")); + System.out.println(" equal: "+test.testunicodestring3("abc").equals("abcdef")); + System.out.println("testunicodestring4 should return ax2def: "+test.testunicodestring4("abcdef")); + System.out.println(" equal: "+test.testunicodestring4("abcdef").equals("ax2def")); + System.out.println("testunicodestring5 should return abcdefghij: "+test.testunicodestring5()); + System.out.println(" equal: "+test.testunicodestring5().equals("abcdefghij")); + System.out.println("testunicodestring6 should return abcdefghi: "+test.testunicodestring6()); + System.out.println(" equal: "+test.testunicodestring6().equals("abcdefghi")); + System.out.println("testunicodestring7 should return xbcdefghi: "+test.testunicodestring7()); + System.out.println(" equal: "+test.testunicodestring7().equals("xbcdefghi")); + + /* regular expression to transform numerical print statements into tests with exceptions: + * search: System\.out\.println\(".*should (?:return|be) ([^:]*): "\+([^\r]*)\); + * replace: if (\2 != \1)\r throw new Exception("Invalid result for \2"); + */ + + if (t.test(10,8) != 3) + throw new Exception("Invalid result for t.test(10,8)"); + if (t.test(20,1) != -1) + throw new Exception("Invalid result for t.test(20,1)"); + if (t.getintfield() != 123) + throw new Exception("Invalid result for t.getintfield()"); + if (t.getstaticbytefield() != 42) + throw new Exception("Invalid result for t.getstaticbytefield()"); + if (test.myrec.a != 42) + throw new Exception("Invalid result for test.myrec.a"); + if (test.myrec.b != 1234) + throw new Exception("Invalid result for test.myrec.b"); + if (test.tcl != 4) + throw new Exception("Invalid result for test.tcl"); + if (test.tcrec.a != 1) + throw new Exception("Invalid result for test.tcrec.a"); + if (test.tcrec.e != 5) + throw new Exception("Invalid result for test.tcrec.e"); + if (test.tcnestrec.r.d != 4) + throw new Exception("Invalid result for test.tcnestrec.r.d"); + if (test.tcnestrec.arr[1] != 6) + throw new Exception("Invalid result for test.tcnestrec.arr[1]"); + if (TMyClass.gettestglobal() != 654321) + throw new Exception("Invalid result for TMyClass.gettestglobal()"); + if (TMyClass.staticmul3(3) != 9) + throw new Exception("Invalid result for TMyClass.staticmul3(3)"); + if (test.testset() != 0) + throw new Exception("Invalid result for test.testset()"); + if (test.testloop() != 0) + throw new Exception("Invalid result for test.testloop()"); + if (test.testfloat() != 0) + throw new Exception("Invalid result for test.testfloat()"); + if (test.testint2real() != 0) + throw new Exception("Invalid result for test.testint2real()"); + if (test.testcnvint1() != 0) + throw new Exception("Invalid result for test.testcnvint1()"); + if (test.TestCmpListOneShort() != 0) + throw new Exception("Invalid result for test.TestCmpListOneShort()"); + if (test.TestCmpListTwoShort() != 0) + throw new Exception("Invalid result for test.TestCmpListTwoShort()"); + if (test.TestCmpListOneWord() != 0) + throw new Exception("Invalid result for test.TestCmpListOneWord()"); + if (test.TestCmpListTwoWord() != 0) + throw new Exception("Invalid result for test.TestCmpListTwoWord()"); + if (test.TestCmpListRangesOneShort() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesOneShort()"); + if (test.TestCmpListRangesTwoShort() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesTwoShort()"); + if (test.TestCmpListRangesOneWord() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesOneWord()"); + if (test.TestCmpListRangesTwoWord() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesTwoWord()"); + if (test.TestCmpListRangesThreeWord() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesThreeWord()"); + if (test.TestCmpListOneInt64() != 0) + throw new Exception("Invalid result for test.TestCmpListOneInt64()"); + if (test.TestCmpListTwoInt64() != 0) + throw new Exception("Invalid result for test.TestCmpListTwoInt64()"); + if (test.TestCmpListThreeInt64() != 0) + throw new Exception("Invalid result for test.TestCmpListThreeInt64()"); + if (test.TestCmpListRangesOneInt64() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesOneInt64()"); + if (test.TestCmpListRangesTwoInt64() != 0) + throw new Exception("Invalid result for test.TestCmpListRangesTwoInt64()"); + if (test.testsqr() != 0) + throw new Exception("Invalid result for test.testsqr()"); + if (test.testtrunc() != 0) + throw new Exception("Invalid result for test.testtrunc()"); + if (test.testdynarr() != 0) + throw new Exception("Invalid result for test.testdynarr()"); + if (test.testdynarr2() != 0) + throw new Exception("Invalid result for test.testdynarr2()"); + if (test.testbitcastintfloat() != 0) + throw new Exception("Invalid result for test.testbitcastintfloat()"); + if (test.testis() != 0) + throw new Exception("Invalid result for test.testis()"); + if (test.testneg() != 0) + throw new Exception("Invalid result for test.testneg()"); + if (test.testtry1() != 0) + throw new Exception("Invalid result for test.testtry1()"); + if (test.testtry2() != 0) + throw new Exception("Invalid result for test.testtry2()"); + if (test.testtryfinally1() != 0) + throw new Exception("Invalid result for test.testtryfinally1()"); + if (test.testtryfinally2() != 0) + throw new Exception("Invalid result for test.testtryfinally2()"); + if (test.testtryfinally3() != 0) + throw new Exception("Invalid result for test.testtryfinally3()"); + if (test.testsmallarr1() != 0) + throw new Exception("Invalid result for test.testsmallarr1()"); + if (test.testsmallarr2() != 0) + throw new Exception("Invalid result for test.testsmallarr2()"); + if (test.testsmallarr3() != 0) + throw new Exception("Invalid result for test.testsmallarr3()"); + if (test.testsmallarr4() != 0) + throw new Exception("Invalid result for test.testsmallarr4()"); + if (test.testopenarr1() != 0) + throw new Exception("Invalid result for test.testopenarr1()"); + if (test.testopenarr2() != 0) + throw new Exception("Invalid result for test.testopenarr2()"); + if (test.testopenarr3() != 0) + throw new Exception("Invalid result for test.testopenarr3()"); + if (test.testopendynarr() != 0) + throw new Exception("Invalid result for test.testopendynarr()"); + if (test.unitintconst != 3) + throw new Exception("Invalid result for test.unitintconst"); + if (test.unitfloatconst != 2.0) + throw new Exception("Invalid result for test.unitfloatconst"); + if (test.unitdoubleconst != 0.1) + throw new Exception("Invalid result for test.unitdoubleconst"); + if (TMyClass.classintconst != 4) + throw new Exception("Invalid result for TMyClass.classintconst"); + if (TMyClass.classfloatconst != 3.0) + throw new Exception("Invalid result for TMyClass.classfloatconst"); + if (TMyClass.classdoubleconst != 0.3) + throw new Exception("Invalid result for TMyClass.classdoubleconst"); + if (intfclass.test(9) != 10) + throw new Exception("Invalid result for intfclass.test(9)"); + if (intf1.test(9) != 10) + throw new Exception("Invalid result for intf1.test(9)"); + if (intfclass.test((byte)9) != 11) + throw new Exception("Invalid result for intfclass.test((byte)9)"); + if (intfclass2.intf4test((long)-12345*2-133) != -2) + throw new Exception("Invalid result for intfclass2.intf4test((long)-12345*2-133)"); + if (tinterface2.iconst != 4) + throw new Exception("Invalid result for tinterface2.iconst"); + if (test.testrec1() != 0) + throw new Exception("Invalid result for test.testrec1()"); + if (test.testopenarr1rec() != 0) + throw new Exception("Invalid result for test.testopenarr1rec()"); + if (test.testrec2() != 0) + throw new Exception("Invalid result for test.testrec2()"); + + +} + +} diff --git a/tests/test/jvm/classlist.pp b/tests/test/jvm/classlist.pp new file mode 100644 index 0000000000..19f3fa89b0 --- /dev/null +++ b/tests/test/jvm/classlist.pp @@ -0,0 +1,30 @@ +program classlist; + +{$mode delphi} + +uses + jdk15; + +type + T1 = class + end; + + CT1 = class of T1; + +function test : string; +var + T : T1; + C : CT1; + L : JUArrayList; +begin + T := T1.Create; + C := CT1(JLObject(T).getClass); + L := JUArrayList.Create; + L.add(JLObject(C)); // ??? + if ct1(l.get(0))<>t1 then + raise JLException.create('error'); +end; + +begin + test; +end. diff --git a/tests/test/jvm/classmeth.pp b/tests/test/jvm/classmeth.pp new file mode 100644 index 0000000000..34ed88f99c --- /dev/null +++ b/tests/test/jvm/classmeth.pp @@ -0,0 +1,43 @@ +program classmeth; + +{$mode delphi} + +type + TElCustomCryptoProviderClass = class of TElCustomCryptoProvider; + TElCustomCryptoProvider = class + class procedure SetAsDefault; + class procedure DoSetAsDefault(Value : TElCustomCryptoProviderClass); + end; + + tc2 = class(TElCustomCryptoProvider) + class procedure SetAsDefault; //reintroduce; + end; + + +var + x: TElCustomCryptoProviderClass; + +class procedure TElCustomCryptoProvider.SetAsDefault; +begin + DoSetAsDefault(Self); /// Illegal expression +end; + +class procedure TElCustomCryptoProvider.DoSetAsDefault(Value : TElCustomCryptoProviderClass); +begin +// SetDefaultCryptoProviderType(Value); + x:=value; +end; + +class procedure tc2.SetAsDefault; +begin + DoSetAsDefault(Self); +end; + +begin + TElCustomCryptoProvider.SetAsDefault; + if x<>TElCustomCryptoProvider then + raise JLException.create('first'); + tc2.SetAsDefault; + if x<>tc2 then + raise JLException.create('second'); +end. diff --git a/tests/test/jvm/forw.pp b/tests/test/jvm/forw.pp new file mode 100644 index 0000000000..dcd88171b4 --- /dev/null +++ b/tests/test/jvm/forw.pp @@ -0,0 +1,33 @@ +{ %norun } + +program forw; + +{$mode delphi} + +type + TC = class + public + procedure execute; + end; + +procedure tc.execute; + + procedure nested1; forward; + + procedure nested2; + begin + + end; + + procedure nested1; + begin + + end; + +begin + +end; + + +begin +end. diff --git a/tests/test/jvm/getbit.pp b/tests/test/jvm/getbit.pp new file mode 100644 index 0000000000..0c75bf5665 --- /dev/null +++ b/tests/test/jvm/getbit.pp @@ -0,0 +1,22 @@ +program getbit; + +{$mode delphi} + +type + plint = class + digits: array of byte; + end; + +function LGetBit(A: PLInt; Bit: Cardinal): Integer; +begin + Result := (A.Digits[(Bit - 1) shr 5 + 1] shr ((Bit - 1) and $1F{(Bit - 1) mod 32})) and 1; +end; + +var + p: plint; +begin + p:=plint.create; + setlength(p.digits,10); + lgetbit(p,4); +end. + diff --git a/tests/test/jvm/nested.pp b/tests/test/jvm/nested.pp new file mode 100644 index 0000000000..a2e2f53c35 --- /dev/null +++ b/tests/test/jvm/nested.pp @@ -0,0 +1,19 @@ +{ %norun } +program nested; + +function test : string; +var + a, b : integer; + + function work : integer; + begin + a := 1; + b := 2; + end; + +begin + work; +end; + +begin +end. diff --git a/tests/test/jvm/outpara.pp b/tests/test/jvm/outpara.pp new file mode 100644 index 0000000000..c14f435daa --- /dev/null +++ b/tests/test/jvm/outpara.pp @@ -0,0 +1,27 @@ +{$mode objfpc} + +unit outpara; + +interface + +procedure test(out l: string); +procedure main(args: array of string); + +implementation + +procedure test(out l: string); +begin + l:='abc'; +end; + +procedure main(args: array of string); +var + x: string; +begin + test(x); + if x<>'abc' then + raise jlexception.Create('wrong') +end; + +end. + diff --git a/tests/test/jvm/sort.pp b/tests/test/jvm/sort.pp new file mode 100644 index 0000000000..239c450e37 --- /dev/null +++ b/tests/test/jvm/sort.pp @@ -0,0 +1,30 @@ +program sort; + +{$mode delphi} + +uses + jdk15; + +function test : string; +var + sa : array of JLObject; + L : JUList; + i : integer; +begin + SetLength(sa, 3); + sa[0] := JLString(string('2')); + sa[1] := JLString(string('3')); + sa[2] := JLString(string('1')); + L := JUArrays.asList(sa); + JUCollections.sort(L); + + Result := ''; + for i := 0 to L.size() - 1 do + Result := Result + string(L.get(i)) + string(' '); +end; + +begin + jlsystem.fout.println(test); + if test<>'1 2 3 ' then + raise JLException.create; +end. diff --git a/tests/test/jvm/tabs.pp b/tests/test/jvm/tabs.pp new file mode 100644 index 0000000000..4ab3739330 --- /dev/null +++ b/tests/test/jvm/tabs.pp @@ -0,0 +1,309 @@ +{ Part of System unit testsuit } +{ Carl Eric Codere Copyright (c) 2002 } +program tabs; + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} +{$endif} + + +{$ifdef VER1_0} + {$define SKIP_CURRENCY_TEST} +{$endif } + +{$ifndef MACOS} +{$APPTYPE CONSOLE} +{$else} +{$APPTYPE TOOL} +{$endif} + +{$R-} +{$Q-} + +const + RESULT_ONE_INT = 65536; + VALUE_ONE_INT = -65536; + RESULT_CONST_ONE_INT = abs(VALUE_ONE_INT); + RESULT_TWO_INT = 12345; + VALUE_TWO_INT = 12345; + RESULT_CONST_TWO_INT = abs(VALUE_TWO_INT); + + RESULT_THREE_INT = 2147483647; + VALUE_THREE_INT = -2147483647; + RESULT_CONST_THREE_INT = abs(VALUE_THREE_INT); + RESULT_FOUR_INT = 2147483647; + VALUE_FOUR_INT = 2147483647; + RESULT_CONST_FOUR_INT = abs(VALUE_FOUR_INT); + + + RESULT_ONE_REAL = 12345.6789; + VALUE_ONE_REAL = -12345.6789; + RESULT_CONST_ONE_REAL = abs(VALUE_ONE_REAL); + RESULT_TWO_REAL = 54321.6789E+02; + VALUE_TWO_REAL = 54321.6789E+02; + RESULT_CONST_TWO_REAL = abs(VALUE_TWO_REAL); + + RESULT_THREE_REAL = 0.0; + VALUE_THREE_REAL = 0.0; + RESULT_CONST_THREE_REAL = abs(VALUE_THREE_REAL); + RESULT_FOUR_REAL = 12.0; + VALUE_FOUR_REAL = -12.0; + RESULT_CONST_FOUR_REAL = abs(VALUE_FOUR_REAL); + + +procedure fail; + begin + WriteLn('Failure!'); + halt(1); + end; + + +{$ifndef SKIP_CURRENCY_TEST} + procedure test_abs_currency; + var + _result : boolean; + value : currency; + value1: currency; + begin + Write('Abs() test with currency type...'); + _result := true; + + value := VALUE_ONE_REAL; + if (trunc(abs(value)) <> trunc(RESULT_CONST_ONE_REAL)) then + _result := false; + + value := VALUE_TWO_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_TWO_REAL) then + _result := false; + + value := VALUE_THREE_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_THREE_REAL) then + _result := false; + + value := VALUE_FOUR_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_FOUR_REAL) then + _result := false; + + value := VALUE_ONE_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_ONE_REAL) then + _result := false; + + value := VALUE_TWO_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_TWO_REAL) then + _result := false; + + value := VALUE_THREE_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_THREE_REAL) then + _result := false; + + value := VALUE_FOUR_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_FOUR_REAL) then + _result := false; + + + if not _result then + fail + else + WriteLn('Success!'); + end; +{$endif SKIP_CURRENCY_TEST} + + + + procedure test_abs_int64; + var + _result : boolean; + value : int64; + value1: int64; + begin + Write('Abs() test with int64 type...'); + _result := true; + + value := VALUE_ONE_INT; + if (abs(value) <> (RESULT_CONST_ONE_INT)) then + _result := false; + + + value := VALUE_TWO_INT; + if abs(value) <> (RESULT_CONST_TWO_INT) then + _result := false; + + value := VALUE_THREE_INT; + if abs(value) <> (RESULT_CONST_THREE_INT) then + _result := false; + + value := VALUE_FOUR_INT; + if abs(value) <> (RESULT_CONST_FOUR_INT) then + _result := false; + + value := VALUE_ONE_INT; + value1 := abs(value); + if value1 <> (RESULT_ONE_INT) then + _result := false; + + value := VALUE_TWO_INT; + value1 := abs(value); + if value1 <> (RESULT_TWO_INT) then + _result := false; + + value := VALUE_THREE_INT; + value1 := abs(value); + if value1 <> (RESULT_THREE_INT) then + _result := false; + + value := VALUE_FOUR_INT; + value1 := abs(value); + if value1 <> (RESULT_FOUR_INT) then + _result := false; + + if not _result then + fail + else + WriteLn('Success!'); + end; + + + procedure test_abs_longint; + var + _result : boolean; + value : longint; + value1: longint; + vsingle : single; + vdouble : double; + vextended : extended; + begin + Write('Abs() test with longint type...'); + _result := true; + + value := VALUE_ONE_INT; + if (abs(value) <> (RESULT_CONST_ONE_INT)) then + _result := false; + + + value := VALUE_TWO_INT; + if abs(value) <> (RESULT_CONST_TWO_INT) then + _result := false; + + value := VALUE_THREE_INT; + if abs(value) <> (RESULT_CONST_THREE_INT) then + _result := false; + + value := VALUE_FOUR_INT; + if abs(value) <> (RESULT_CONST_FOUR_INT) then + _result := false; + + value := VALUE_ONE_INT; + value1 := abs(value); + if value1 <> (RESULT_ONE_INT) then + _result := false; + + value := VALUE_TWO_INT; + value1 := abs(value); + if value1 <> (RESULT_TWO_INT) then + _result := false; + + value := VALUE_THREE_INT; + value1 := abs(value); + if value1 <> (RESULT_THREE_INT) then + _result := false; + + value := VALUE_FOUR_INT; + value1 := abs(value); + if value1 <> (RESULT_FOUR_INT) then + _result := false; + + value := VALUE_ONE_INT; + vsingle := abs(value); + if (round(vsingle) <> RESULT_ONE_INT) then + _result := false; + + value := VALUE_ONE_INT; + vdouble := abs(value); + if (round(vdouble) <> RESULT_ONE_INT) then + _result := false; + + value := VALUE_ONE_INT; + vextended := abs(value); + if (round(vextended) <> RESULT_ONE_INT) then + _result := false; + + if not _result then + fail + else + WriteLn('Success!'); + end; + + procedure test_abs_real; + var + _result : boolean; + value : real; + value1: real; + begin + _result := true; + Write('Abs() test with real type...'); + + value := VALUE_ONE_REAL; + if (trunc(abs(value)) <> trunc(RESULT_CONST_ONE_REAL)) then + _result := false; + + value := VALUE_TWO_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_TWO_REAL) then + _result := false; + + value := VALUE_THREE_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_THREE_REAL) then + _result := false; + + value := VALUE_FOUR_REAL; + if trunc(abs(value)) <> trunc(RESULT_CONST_FOUR_REAL) then + _result := false; + + value := VALUE_ONE_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_ONE_REAL) then + _result := false; + + value := VALUE_TWO_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_TWO_REAL) then + _result := false; + + value := VALUE_THREE_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_THREE_REAL) then + _result := false; + + value := VALUE_FOUR_REAL; + value1 := abs(value); + if trunc(value1) <> trunc(RESULT_FOUR_REAL) then + _result := false; + + if not _result then + fail + else + WriteLn('Success!'); + end; + +var + r: longint; + _success : boolean; + l: boolean; +Begin +{$ifdef SKIP_CURRENCY_TEST} + Writeln('Skipping currency test because its not supported by theis compiler'); +{$else SKIP_CURRENCY_TEST} + test_abs_currency; +{$endif SKIP_CURRENCY_TEST} + test_abs_real; + test_abs_longint; + test_abs_int64; +end. diff --git a/tests/test/jvm/taddset.pp b/tests/test/jvm/taddset.pp new file mode 100644 index 0000000000..0bb13e6642 --- /dev/null +++ b/tests/test/jvm/taddset.pp @@ -0,0 +1,655 @@ +{****************************************************************} +{ CODE GENERATOR TEST PROGRAM } +{****************************************************************} +{ NODE TESTED : secondadd() } +{****************************************************************} +{ PRE-REQUISITES: secondload() } +{ secondassign() } +{ secondsetelement() } +{****************************************************************} +{ DEFINES: } +{ FPC = Target is FreePascal compiler } +{****************************************************************} +{ REMARKS: } +{ } +{ } +{ } +{****************************************************************} + +Program taddset; + +{$modeswitch exceptions} + +{$macro on} +{$define write:=jlsystem.fout.print} +{$define writeln:=jlsystem.fout.println} + +uses + jdk15; + +procedure halt(l: longint); +begin + write('exit code: '); + writeln(l); + raise jlexception.create('error'); +end; + +var + Err : boolean; + +type + { DO NOT CHANGE THE VALUES OF THESE ENUMERATIONS! } + tsmallenum = (dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr); + tasmop = (A_ABCD, + A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI, + A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI, + A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS, + A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK, + A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE, + A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA, + A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU, + A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR, + A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ, + A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX, + A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL, + A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE, + A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE, + A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ, + A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK, + A_RTE,A_RESET,A_STOP, + { MC68010 instructions } + A_BKPT,A_MOVEC,A_MOVES,A_RTD, + { MC68020 instructions } + A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO, + A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2, + A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM, + A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT, + A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE, + A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK, + { FPU Processor instructions - directly supported only. } + { IEEE aware and misc. condition codes not supported } + A_FABS,A_FADD, + A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE, + A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE, + A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE, + A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE, + A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE, + A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE, + A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM, + A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV, + A_FSFLMUL,A_FTST, + A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE, + A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE, + { Protected instructions } + A_CPRESTORE,A_CPSAVE, + { FPU Unit protected instructions } + { and 68030/68851 common MMU instructions } + { (this may include 68040 MMU instructions) } + A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST, + { Useful for assembly langage output } + A_LABEL,A_NONE); + + + +type + topset = set of tasmop; + tsmallset = set of tsmallenum; + +const + + { NORMAL SETS } + constset1 : array[1..3] of topset = + ( + { 66 } { 210 } { 225 } + ([A_MOVE, { 66 : LONG 2 - BIT 2 } + A_FTST, { 210 : LONG 6 - BIT 18 } + A_CPSAVE]),{ 225 : LONG 7 - BIT 1 } + { 1..8 } + ([A_ADD..A_ASL]), + { 134 } + ([A_CHK2]) + ); + + constset2 : array[1..3] of topset = + ( + ([A_MOVE,A_FTST,A_CPSAVE]), + ([A_ADD..A_ASL]), + ([A_CHK2]) + ); + + { SMALL SETS } + constset3 : array[1..3] of tsmallset = + ( + ([DA, { 0 : LONG 0 : bit 0 } + DD, { 3 : LONG 0 : bit 3 } + DM]), { 12 : LONG 0 : bit 12 } + ([DB..DI]), { 1..8 : LONG 0 : bits 1-8 } + ([DR]) { 17 : LONG 0 : bit 17 } + ); + + constset4 : array[1..3] of tsmallset = + ( + ([DA,DD,DM]), + ([DB..DI]), + ([DR]) + ); + + + procedure CheckPassed(passed:boolean); + begin + if passed then + WriteLn('Success.') + else + begin + WriteLn('Failure.'); + Halt(1); + Err:=true; + end; + end; + + procedure SetTestEqual; + { FPC_SET_COMP_SETS } + var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; + Begin + Write('Normal Set == Normal Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if not (constset1[2] = constset2[2]) then + passed := false; + if (constset1[1] = constset2[2]) then + passed := false; + if not (constset1[1] = [A_MOVE,A_FTST,A_CPSAVE]) then + passed := false; + CheckPassed(passed); + end; + + procedure SetTestNotEqual; + { FPC_SET_COMP_SETS } + var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; + Begin + Write('Normal Set <> Normal Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if (constset1[2] <> constset2[2]) then + passed := false; + if not (constset1[1] <> constset2[2]) then + passed := false; +{ if ( [A_ADD] <> [A_ADD] ) then optimized out. + passed := false; + if ( [A_BLE..A_BPL] <> [A_BLE..A_BPL] ) then + passed := false; } + if (constset1[1] <> [A_MOVE,A_FTST,A_CPSAVE]) then + passed := false; + CheckPassed(passed); + end; + + procedure SetTestLt; + var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; + begin + Write('Normal Set <= Normal Set test...'); + passed := true; + if constset1[1] <= constset2[2] then + passed := false; + oplist := []; + op2list := [A_MOVE]; + if op2list <= oplist then + passed := false; + oplist := [A_MOVE,A_CPRESTORE..A_CPSAVE]; + if oplist <= op2list then + passed := false; + CheckPassed(passed); + end; + + Procedure SetTestAddOne; + { FPC_SET_SET_BYTE } + { FPC_SET_ADD_SETS } + var + op : tasmop; + oplist: set of tasmop; + Begin + Write('Set + Set element testing...'); + op:=A_LABEL; + oplist:=[]; + oplist:=oplist+[op]; + CheckPassed(oplist = [A_LABEL]); + end; + +Procedure SetTestAddTwo; +{ SET_ADD_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; +Begin + Write('Complex Set + Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_LABEL]; + oplist:=op2list+oplist; + CheckPassed(oplist = [A_MOVE,A_JSR,A_LABEL]); +end; + + + + + +Procedure SetTestSubOne; +{ SET_SUB_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; + op :tasmop; + passed : boolean; +Begin + Write('Set - Set element testing...'); + passed := true; + op2list:=[]; + oplist:=[]; + op := A_TRACS; + oplist:=[A_MOVE]+[A_JSR]+[op]; + op2list:=[A_MOVE]+[A_JSR]; + oplist:=oplist-op2list; + if oplist <> [A_TRACS] then + passed := false; + + oplist:=[A_MOVE]+[A_JSR]+[op]; + op2list:=[A_MOVE]+[A_JSR]; + oplist:=op2list-oplist; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + +Procedure SetTestSubTwo; +{ FPC_SET_SUB_SETS } +const + b: tasmop = (A_BSR); +var + op2list :set of tasmop; + oplist: set of tasmop; + op : tasmop; + passed : boolean; +Begin + Write('Complex Set - Set element testing...'); + op := A_BKPT; + passed := true; + oplist:=[A_MOVE]+[A_JSR]-[op]; + op2list:=[A_MOVE]+[A_JSR]; + if oplist <> op2list then + passed := false; + oplist := [A_MOVE]; + oplist := oplist - [A_MOVE]; + if oplist <> [] then + passed := false; + oplist := oplist + [b]; + if oplist <> [b] then + passed := false; + oplist := oplist - [b]; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + + +Procedure SetTestMulSets; +{ FPC_SET_MUL_SETS } +var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; +Begin + passed := true; + Write('Set * Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[A_MOVE]+[A_JSR]; + op2list:=[A_MOVE]; + oplist:=oplist*op2list; + if oplist <> [A_JSR] then + passed := false; + oplist := [A_MOVE,A_FTST]; + op2list := [A_MOVE,A_FTST]; + oplist := oplist * op2list; + if oplist <> [A_MOVE,A_FTST] then + passed := false; + CheckPassed(passed); +end; + +procedure SetTestRange; +var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; + op1 : tasmop; + op2 : tasmop; +begin + passed := true; + Write('Range Set + element testing...'); + op1 := A_ADD; + op2 := A_ASL; + oplist := []; + oplist := [op1..op2]; + if oplist <> constset1[2] then + passed := false; + CheckPassed(passed); +end; + +procedure SetTestByte; +var + op2list :set of tasmop; + oplist: set of tasmop; + passed : boolean; + op1 : tasmop; + op2 : tasmop; + op : tasmop; +begin + Write('Simple Set + element testing...'); + passed := true; + op := A_LABEL; + oplist := [A_MOVE,op,A_JSR]; + if oplist <> [A_MOVE,A_LABEL,A_JSR] then + passed := false; + CheckPassed(passed); +end; + + +{------------------------------ TESTS FOR SMALL VALUES ---------------------} + procedure SmallSetTestEqual; + var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; + Begin + Write('Small Set == Small Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if not (constset3[2] = constset4[2]) then + passed := false; + if (constset3[1] = constset4[2]) then + passed := false; + if not (constset3[1] = [DA,DD,DM]) then + passed := false; + CheckPassed(passed); + end; + + procedure SmallSetTestNotEqual; + var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; + Begin + Write('Small Set <> Small Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if (constset3[2] <> constset4[2]) then + passed := false; + if not (constset3[1] <> constset4[2]) then + passed := false; +{ if ( [A_ADD] <> [A_ADD] ) then optimized out. + passed := false; + if ( [A_BLE..A_BPL] <> [A_BLE..A_BPL] ) then + passed := false; } + if (constset3[1] <> [DA,DD,DM]) then + passed := false; + CheckPassed(passed); + end; + + procedure SmallSetTestLt; + var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; + begin + Write('Small Set <= Small Set test...'); + passed := true; + if constset3[1] <= constset4[2] then + passed := false; + oplist := []; + op2list := [DC]; + if op2list <= oplist then + passed := false; + oplist := [DC,DF..DM]; + if oplist <= op2list then + passed := false; + CheckPassed(passed); + end; + + Procedure SmallSetTestAddOne; + var + op : tsmallenum; + oplist: set of tsmallenum; + Begin + Write('Small Set + Small Set element testing...'); + op:=DG; + oplist:=[]; + oplist:=oplist+[op]; + CheckPassed( oplist = [DG] ); + end; + +Procedure SmallSetTestAddTwo; +var + op2list :set of tsmallenum; + oplist: set of tsmallenum; +Begin + Write('Small Complex Set + Small Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[DG]+[DI]; + op2list:=[DM]; + oplist:=op2list+oplist; + CheckPassed( oplist = [DG,DI,DM] ); +end; + + +Procedure SmallSetTestSubOne; +var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + op :tsmallenum; + passed : boolean; +Begin + Write('Small Set - Small Set element testing...'); + passed := true; + op2list:=[]; + oplist:=[]; + op := DL; + oplist:=[DG]+[DI]+[op]; + op2list:=[DG]+[DI]; + oplist:=oplist-op2list; + if oplist <> [DL] then + passed := false; + + oplist:=[DG]+[DI]+[op]; + op2list:=[DG]+[DI]; + oplist:=op2list-oplist; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + +Procedure SmallSetTestSubTwo; +const + b: tsmallenum = (DH); +var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + op : tsmallenum; + passed : boolean; +Begin + Write('Small Complex Set - Small Set element testing...'); + op := DL; + passed := true; + oplist:=[DG]+[DI]-[op]; + op2list:=[DG]+[DI]; + if oplist <> op2list then + passed := false; + oplist := [DG]; + oplist := oplist - [DG]; + if oplist <> [] then + passed := false; + oplist := oplist + [b]; + if oplist <> [b] then + passed := false; + oplist := oplist - [b]; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + + +Procedure SmallSetTestMulSets; +var + op2list : set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; +Begin + passed := true; + Write('Small Set * Small Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[DG]+[DI]; + op2list:=[DG]; + oplist:=oplist*op2list; + if oplist <> [DI] then + passed := false; + oplist := [DG,DK]; + op2list := [DG,DK]; + oplist := oplist * op2list; + if oplist <> [DG,DK] then + passed := false; + CheckPassed(passed); +end; + +procedure SmallSetTestRange; +var + op2list :set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; + op1 : tsmallenum; + op2 : tsmallenum; +begin + passed := true; + Write('Small Range Set + element testing...'); + op1 := DB; + op2 := DI; + oplist := []; + oplist := [op1..op2]; + if oplist <> constset3[2] then + passed := false; + CheckPassed(passed); +end; + +procedure SmallSetTestByte; +var + op2list : set of tsmallenum; + oplist: set of tsmallenum; + passed : boolean; + op1 : tsmallenum; + op2 : tsmallenum; + op : tsmallenum; +begin + Write('Small Simple Set + element testing...'); + passed := true; + op := DD; + oplist := [DG,op,DI]; + if oplist <> [DG,DD,DI] then + passed := false; + CheckPassed(passed); +end; + +(* + +const + b: myenum = (dA); +var + enum: set of myenum; + oplist: set of tasmop; + l : word; +Begin + SetTestEqual; + SetTestNotEqual; +{ small sets } + enum:=[]; + { add } + enum:=enum+[da]; + { subtract } + enum:=enum-[da]; + if DA in enum then + WriteLn('Found A_LABEL'); + { very large sets } + { copy loop test } + WRITELN('LARGE SETS:'); + oplist := [A_LABEL]; + { secondin test } + if A_LABEL in oplist then + WriteLn('TESTING SIMPLE SECOND_IN: PASSED.'); + { } + oplist:=[]; + if A_LABEL in oplist then + WriteLn('SECOND IN FAILED.'); +{ SecondinSets;} + SetSetByte; + SetAddSets; + SetSubSets; + SetCompSets; + SetMulSets; + WRITELN('SMALL SETS:'); + SmallInSets; + SmallAddSets; + SmallSubSets; + SmallCompSets; + SmallMulSets; + l:=word(A_CPRESTORE); + if l = word(A_CPRESTORE) then + Begin + end; + +*) +Begin + WriteLn('----------------------- Normal sets -----------------------'); + { Normal sets } + SetTestEqual; + SetTestNotEqual; + SetTestAddOne; + SetTestAddTwo; + SetTestSubOne; + SetTestSubTwo; + SetTestRange; + SetTestLt; + SetTestByte; + { Small sets } + WriteLn('----------------------- Small sets -----------------------'); + SmallSetTestEqual; + SmallSetTestNotEqual; + SmallSetTestAddOne; + SmallSetTestAddTwo; + SmallSetTestSubOne; + SmallSetTestSubTwo; + SmallSetTestRange; + SmallSetTestLt; + SmallSetTestByte; + + if Err then + Halt(1); +end. diff --git a/tests/test/jvm/taddsetint.pp b/tests/test/jvm/taddsetint.pp new file mode 100644 index 0000000000..c21747d44c --- /dev/null +++ b/tests/test/jvm/taddsetint.pp @@ -0,0 +1,658 @@ +{****************************************************************} +{ CODE GENERATOR TEST PROGRAM } +{****************************************************************} +{ NODE TESTED : secondadd() } +{****************************************************************} +{ PRE-REQUISITES: secondload() } +{ secondassign() } +{ secondsetelement() } +{****************************************************************} +{ DEFINES: } +{ FPC = Target is FreePascal compiler } +{****************************************************************} +{ REMARKS: } +{ } +{ } +{ } +{****************************************************************} + +Program taddsetint; + +{$modeswitch exceptions} + +{$macro on} +{$define write:=jlsystem.fout.print} +{$define writeln:=jlsystem.fout.println} + +uses + jdk15; + +procedure halt(l: longint); +begin + write('exit code: '); + writeln(l); + raise jlexception.create('error'); +end; + +var + Err : boolean; + +type + { DO NOT CHANGE THE VALUES OF THESE ENUMERATIONS! } + tsmallenum = (dA,dB,dC,dd,de,df,dg,dh,di,dj,dk,dl,dm,dn,dop,dp,dq,dr); + tasmop = (A_ABCD, + A_ADD,A_ADDA,A_ADDI,A_ADDQ,A_ADDX,A_AND,A_ANDI, + A_ASL,A_ASR,A_BCC,A_BCS,A_BEQ,A_BGE,A_BGT,A_BHI, + A_BLE,A_BLS,A_BLT,A_BMI,A_BNE,A_BPL,A_BVC,A_BVS, + A_BCHG,A_BCLR,A_BRA,A_BSET,A_BSR,A_BTST,A_CHK, + A_CLR,A_CMP,A_CMPA,A_CMPI,A_CMPM,A_DBCC,A_DBCS,A_DBEQ,A_DBGE, + A_DBGT,A_DBHI,A_DBLE,A_DBLS,A_DBLT,A_DBMI,A_DBNE,A_DBRA, + A_DBPL,A_DBT,A_DBVC,A_DBVS,A_DBF,A_DIVS,A_DIVU, + A_EOR,A_EORI,A_EXG,A_ILLEGAL,A_EXT,A_JMP,A_JSR, + A_LEA,A_LINK,A_LSL,A_LSR,A_MOVE,A_MOVEA,A_MOVEI,A_MOVEQ, + A_MOVEM,A_MOVEP,A_MULS,A_MULU,A_NBCD,A_NEG,A_NEGX, + A_NOP,A_NOT,A_OR,A_ORI,A_PEA,A_ROL,A_ROR,A_ROXL, + A_ROXR,A_RTR,A_RTS,A_SBCD,A_SCC,A_SCS,A_SEQ,A_SGE, + A_SGT,A_SHI,A_SLE,A_SLS,A_SLT,A_SMI,A_SNE, + A_SPL,A_ST,A_SVC,A_SVS,A_SF,A_SUB,A_SUBA,A_SUBI,A_SUBQ, + A_SUBX,A_SWAP,A_TAS,A_TRAP,A_TRAPV,A_TST,A_UNLK, + A_RTE,A_RESET,A_STOP, + { MC68010 instructions } + A_BKPT,A_MOVEC,A_MOVES,A_RTD, + { MC68020 instructions } + A_BFCHG,A_BFCLR,A_BFEXTS,A_BFEXTU,A_BFFFO, + A_BFINS,A_BFSET,A_BFTST,A_CALLM,A_CAS,A_CAS2, + A_CHK2,A_CMP2,A_DIVSL,A_DIVUL,A_EXTB,A_PACK,A_RTM, + A_TRAPCC,A_TRACS,A_TRAPEQ,A_TRAPF,A_TRAPGE,A_TRAPGT, + A_TRAPHI,A_TRAPLE,A_TRAPLS,A_TRAPLT,A_TRAPMI,A_TRAPNE, + A_TRAPPL,A_TRAPT,A_TRAPVC,A_TRAPVS,A_UNPK, + { FPU Processor instructions - directly supported only. } + { IEEE aware and misc. condition codes not supported } + A_FABS,A_FADD, + A_FBEQ,A_FBNE,A_FBNGT,A_FBGT,A_FBGE,A_FBNGE, + A_FBLT,A_FBNLT,A_FBLE,A_FBGL,A_FBNGL,A_FBGLE,A_FBNGLE, + A_FDBEQ,A_FDBNE,A_FDBGT,A_FDBNGT,A_FDBGE,A_FDBNGE, + A_FDBLT,A_FDBNLT,A_FDBLE,A_FDBGL,A_FDBNGL,A_FDBGLE,A_FBDNGLE, + A_FSEQ,A_FSNE,A_FSGT,A_FSNGT,A_FSGE,A_FSNGE, + A_FSLT,A_FSNLT,A_FSLE,A_FSGL,A_FSNGL,A_FSGLE,A_FSNGLE, + A_FCMP,A_FDIV,A_FMOVE,A_FMOVEM, + A_FMUL,A_FNEG,A_FNOP,A_FSQRT,A_FSUB,A_FSGLDIV, + A_FSFLMUL,A_FTST, + A_FTRAPEQ,A_FTRAPNE,A_FTRAPGT,A_FTRAPNGT,A_FTRAPGE,A_FTRAPNGE, + A_FTRAPLT,A_FTRAPNLT,A_FTRAPLE,A_FTRAPGL,A_FTRAPNGL,A_FTRAPGLE,A_FTRAPNGLE, + { Protected instructions } + A_CPRESTORE,A_CPSAVE, + { FPU Unit protected instructions } + { and 68030/68851 common MMU instructions } + { (this may include 68040 MMU instructions) } + A_FRESTORE,A_FSAVE,A_PFLUSH,A_PFLUSHA,A_PLOAD,A_PMOVE,A_PTEST, + { Useful for assembly langage output } + A_LABEL,A_NONE); + + tsmallenumint = ord(low(tsmallenum))..ord(high(tsmallenum)); + tasmopint = ord(low(tasmop))..ord(high(tasmop)); + + + +type + topset = set of tasmopint; + tsmallset = set of tsmallenumint; + +const + + { NORMAL SETS } + constset1 : array[1..3] of topset = + ( + { 66 } { 210 } { 225 } + ([ord(A_MOVE), { 66 : LONG 2 - BIT 2 } + ord(A_FTST), { 210 : LONG 6 - BIT 18 } + ord(A_CPSAVE)]),{ 225 : LONG 7 - BIT 1 } + { 1..8 } + ([ord(A_ADD)..ord(A_ASL)]), + { 134 } + ([ord(A_CHK2)]) + ); + + constset2 : array[1..3] of topset = + ( + ([ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]), + ([ord(A_ADD)..ord(A_ASL)]), + ([ord(A_CHK2)]) + ); + + { SMALL SETS } + constset3 : array[1..3] of tsmallset = + ( + ([ord(DA), { 0 : LONG 0 : bit 0 } + ord(DD), { 3 : LONG 0 : bit 3 } + ord(DM)]), { 12 : LONG 0 : bit 12 } + ([ord(DB)..ord(DI)]), { 1..8 : LONG 0 : bits 1-8 } + ([ord(DR)]) { 17 : LONG 0 : bit 17 } + ); + + constset4 : array[1..3] of tsmallset = + ( + ([ord(DA),ord(DD),ord(DM)]), + ([ord(DB)..ord(DI)]), + ([ord(DR)]) + ); + + + procedure CheckPassed(passed:boolean); + begin + if passed then + WriteLn('Success.') + else + begin + WriteLn('Failure.'); + Halt(1); + Err:=true; + end; + end; + + procedure SetTestEqual; + { FPC_SET_COMP_SETS } + var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; + Begin + Write('Normal Set == Normal Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if not (constset1[2] = constset2[2]) then + passed := false; + if (constset1[1] = constset2[2]) then + passed := false; + if not (constset1[1] = [ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]) then + passed := false; + CheckPassed(passed); + end; + + procedure SetTestNotEqual; + { FPC_SET_COMP_SETS } + var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; + Begin + Write('Normal Set <> Normal Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if (constset1[2] <> constset2[2]) then + passed := false; + if not (constset1[1] <> constset2[2]) then + passed := false; +{ if ( [ord(A_ADD)] <> [ord(A_ADD)] ) then optimized out. + passed := false; + if ( [ord(A_BLE)..ord(A_BPL)] <> [ord(A_BLE)..ord(A_BPL)] ) then + passed := false; } + if (constset1[1] <> [ord(A_MOVE),ord(A_FTST),ord(A_CPSAVE)]) then + passed := false; + CheckPassed(passed); + end; + + procedure SetTestLt; + var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; + begin + Write('Normal Set <= Normal Set test...'); + passed := true; + if constset1[1] <= constset2[2] then + passed := false; + oplist := []; + op2list := [ord(A_MOVE)]; + if op2list <= oplist then + passed := false; + oplist := [ord(A_MOVE),ord(A_CPRESTORE)..ord(A_CPSAVE)]; + if oplist <= op2list then + passed := false; + CheckPassed(passed); + end; + + Procedure SetTestAddOne; + { FPC_SET_SET_BYTE } + { FPC_SET_ADD_SETS } + var + op : tasmopint; + oplist: set of tasmopint; + Begin + Write('Set + Set element testing...'); + op:=ord(A_LABEL); + oplist:=[]; + oplist:=oplist+[op]; + CheckPassed(oplist = [ord(A_LABEL)]); + end; + +Procedure SetTestAddTwo; +{ SET_ADD_SETS } +var + op2list :set of tasmopint; + oplist: set of tasmopint; +Begin + Write('Complex Set + Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[ord(A_MOVE)]+[ord(A_JSR)]; + op2list:=[ord(A_LABEL)]; + oplist:=op2list+oplist; + CheckPassed(oplist = [ord(A_MOVE),ord(A_JSR),ord(A_LABEL)]); +end; + + + + + +Procedure SetTestSubOne; +{ SET_SUB_SETS } +var + op2list :set of tasmopint; + oplist: set of tasmopint; + op :tasmopint; + passed : boolean; +Begin + Write('Set - Set element testing...'); + passed := true; + op2list:=[]; + oplist:=[]; + op := ord(A_TRACS); + oplist:=[ord(A_MOVE)]+[ord(A_JSR)]+[op]; + op2list:=[ord(A_MOVE)]+[ord(A_JSR)]; + oplist:=oplist-op2list; + if oplist <> [ord(A_TRACS)] then + passed := false; + + oplist:=[ord(A_MOVE)]+[ord(A_JSR)]+[op]; + op2list:=[ord(A_MOVE)]+[ord(A_JSR)]; + oplist:=op2list-oplist; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + +Procedure SetTestSubTwo; +{ FPC_SET_SUB_SETS } +const + b: tasmopint = (ord(A_BSR)); +var + op2list :set of tasmopint; + oplist: set of tasmopint; + op : tasmopint; + passed : boolean; +Begin + Write('Complex Set - Set element testing...'); + op := ord(A_BKPT); + passed := true; + oplist:=[ord(A_MOVE)]+[ord(A_JSR)]-[op]; + op2list:=[ord(A_MOVE)]+[ord(A_JSR)]; + if oplist <> op2list then + passed := false; + oplist := [ord(A_MOVE)]; + oplist := oplist - [ord(A_MOVE)]; + if oplist <> [] then + passed := false; + oplist := oplist + [b]; + if oplist <> [b] then + passed := false; + oplist := oplist - [b]; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + + +Procedure SetTestMulSets; +{ FPC_SET_MUL_SETS } +var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; +Begin + passed := true; + Write('Set * Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[ord(A_MOVE)]+[ord(A_JSR)]; + op2list:=[ord(A_MOVE)]; + oplist:=oplist*op2list; + if oplist <> [ord(A_JSR)] then + passed := false; + oplist := [ord(A_MOVE),ord(A_FTST)]; + op2list := [ord(A_MOVE),ord(A_FTST)]; + oplist := oplist * op2list; + if oplist <> [ord(A_MOVE),ord(A_FTST)] then + passed := false; + CheckPassed(passed); +end; + +procedure SetTestRange; +var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; + op1 : tasmopint; + op2 : tasmopint; +begin + passed := true; + Write('Range Set + element testing...'); + op1 := ord(A_ADD); + op2 := ord(A_ASL); + oplist := []; + oplist := [op1..op2]; + if oplist <> constset1[2] then + passed := false; + CheckPassed(passed); +end; + +procedure SetTestByte; +var + op2list :set of tasmopint; + oplist: set of tasmopint; + passed : boolean; + op1 : tasmopint; + op2 : tasmopint; + op : tasmopint; +begin + Write('Simple Set + element testing...'); + passed := true; + op := ord(A_LABEL); + oplist := [ord(A_MOVE),op,ord(A_JSR)]; + if oplist <> [ord(A_MOVE),ord(A_LABEL),ord(A_JSR)] then + passed := false; + CheckPassed(passed); +end; + + +{------------------------------ TESTS FOR SMALL VALUES ---------------------} + procedure SmallSetTestEqual; + var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; + Begin + Write('Small Set == Small Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if not (constset3[2] = constset4[2]) then + passed := false; + if (constset3[1] = constset4[2]) then + passed := false; + if not (constset3[1] = [ord(DA),ord(DD),ord(DM)]) then + passed := false; + CheckPassed(passed); + end; + + procedure SmallSetTestNotEqual; + var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; + Begin + Write('Small Set <> Small Set test...'); + passed := true; + op2list:=[]; + oplist:=[]; + if not (oplist=op2list) then + passed := false; + if (constset3[2] <> constset4[2]) then + passed := false; + if not (constset3[1] <> constset4[2]) then + passed := false; +{ if ( [ord(A_ADD)] <> [ord(A_ADD)] ) then optimized out. + passed := false; + if ( [ord(A_BLE)..ord(A_BPL)] <> [ord(A_BLE)..ord(A_BPL)] ) then + passed := false; } + if (constset3[1] <> [ord(DA),ord(DD),ord(DM)]) then + passed := false; + CheckPassed(passed); + end; + + procedure SmallSetTestLt; + var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; + begin + Write('Small Set <= Small Set test...'); + passed := true; + if constset3[1] <= constset4[2] then + passed := false; + oplist := []; + op2list := [ord(DC)]; + if op2list <= oplist then + passed := false; + oplist := [ord(DC),ord(DF)..ord(DM)]; + if oplist <= op2list then + passed := false; + CheckPassed(passed); + end; + + Procedure SmallSetTestAddOne; + var + op : tsmallenumint; + oplist: set of tsmallenumint; + Begin + Write('Small Set + Small Set element testing...'); + op:=ord(DG); + oplist:=[]; + oplist:=oplist+[op]; + CheckPassed( oplist = [ord(DG)] ); + end; + +Procedure SmallSetTestAddTwo; +var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; +Begin + Write('Small Complex Set + Small Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[ord(DG)]+[ord(DI)]; + op2list:=[ord(DM)]; + oplist:=op2list+oplist; + CheckPassed( oplist = [ord(DG),ord(DI),ord(DM)] ); +end; + + +Procedure SmallSetTestSubOne; +var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + op :tsmallenumint; + passed : boolean; +Begin + Write('Small Set - Small Set element testing...'); + passed := true; + op2list:=[]; + oplist:=[]; + op := ord(DL); + oplist:=[ord(DG)]+[ord(DI)]+[op]; + op2list:=[ord(DG)]+[ord(DI)]; + oplist:=oplist-op2list; + if oplist <> [ord(DL)] then + passed := false; + + oplist:=[ord(DG)]+[ord(DI)]+[op]; + op2list:=[ord(DG)]+[ord(DI)]; + oplist:=op2list-oplist; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + +Procedure SmallSetTestSubTwo; +const + b: tsmallenumint = (ord(DH)); +var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + op : tsmallenumint; + passed : boolean; +Begin + Write('Small Complex Set - Small Set element testing...'); + op := ord(DL); + passed := true; + oplist:=[ord(DG)]+[ord(DI)]-[op]; + op2list:=[ord(DG)]+[ord(DI)]; + if oplist <> op2list then + passed := false; + oplist := [ord(DG)]; + oplist := oplist - [ord(DG)]; + if oplist <> [] then + passed := false; + oplist := oplist + [b]; + if oplist <> [b] then + passed := false; + oplist := oplist - [b]; + if oplist <> [] then + passed := false; + CheckPassed(passed); +end; + + +Procedure SmallSetTestMulSets; +var + op2list : set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; +Begin + passed := true; + Write('Small Set * Small Set element testing...'); + op2list:=[]; + oplist:=[]; + oplist:=[ord(DG)]+[ord(DI)]; + op2list:=[ord(DG)]; + oplist:=oplist*op2list; + if oplist <> [ord(DI)] then + passed := false; + oplist := [ord(DG),ord(DK)]; + op2list := [ord(DG),ord(DK)]; + oplist := oplist * op2list; + if oplist <> [ord(DG),ord(DK)] then + passed := false; + CheckPassed(passed); +end; + +procedure SmallSetTestRange; +var + op2list :set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; + op1 : tsmallenumint; + op2 : tsmallenumint; +begin + passed := true; + Write('Small Range Set + element testing...'); + op1 := ord(DB); + op2 := ord(DI); + oplist := []; + oplist := [op1..op2]; + if oplist <> constset3[2] then + passed := false; + CheckPassed(passed); +end; + +procedure SmallSetTestByte; +var + op2list : set of tsmallenumint; + oplist: set of tsmallenumint; + passed : boolean; + op1 : tsmallenumint; + op2 : tsmallenumint; + op : tsmallenumint; +begin + Write('Small Simple Set + element testing...'); + passed := true; + op := ord(DD); + oplist := [ord(DG),op,ord(DI)]; + if oplist <> [ord(DG),ord(DD),ord(DI)] then + passed := false; + CheckPassed(passed); +end; + +(* + +const + b: myenum = (ord(dA)); +var + enum: set of myenum; + oplist: set of tasmopint; + l : word; +Begin + SetTestEqual; + SetTestNotEqual; +{ small sets } + enum:=[]; + { add } + enum:=enum+[ord(da)]; + { subtract } + enum:=enum-[ord(da)]; + if ord(DA) in enum then + WriteLn('Found ord(A_LABEL)'); + { very large sets } + { copy loop test } + WRITELN('LARGE SETS:'); + oplist := [ord(A_LABEL)]; + { secondin test } + if ord(A_LABEL) in oplist then + WriteLn('TESTING SIMPLE SECOND_IN: PASSED.'); + { } + oplist:=[]; + if ord(A_LABEL) in oplist then + WriteLn('SECOND IN FAILED.'); +{ SecondinSets;} + SetSetByte; + SetAddSets; + SetSubSets; + SetCompSets; + SetMulSets; + WRITELN('SMALL SETS:'); + SmallInSets; + SmallAddSets; + SmallSubSets; + SmallCompSets; + SmallMulSets; + l:=word(ord(A_CPRESTORE)); + if l = word(ord(A_CPRESTORE)) then + Begin + end; + +*) +Begin + WriteLn('----------------------- Normal sets -----------------------'); + { Normal sets } + SetTestEqual; + SetTestNotEqual; + SetTestAddOne; + SetTestAddTwo; + SetTestSubOne; + SetTestSubTwo; + SetTestRange; + SetTestLt; + SetTestByte; + { Small sets } + WriteLn('----------------------- Small sets -----------------------'); + SmallSetTestEqual; + SmallSetTestNotEqual; + SmallSetTestAddOne; + SmallSetTestAddTwo; + SmallSetTestSubOne; + SmallSetTestSubTwo; + SmallSetTestRange; + SmallSetTestLt; + SmallSetTestByte; + + if Err then + Halt(1); +end. diff --git a/tests/test/jvm/tarray2.pp b/tests/test/jvm/tarray2.pp new file mode 100644 index 0000000000..70243ad5e4 --- /dev/null +++ b/tests/test/jvm/tarray2.pp @@ -0,0 +1,124 @@ +{$mode objfpc} +Program tarray2; + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.print} + +{$else} +uses + SysUtils; +{$endif} + +{ Program to test array of const } + +{ All elements of the following record must be tested : + Elements not yet tested are commented out. + + Type + PVarRec = ^TVarRec; + TVarRec = record + case vType: Byte of + vtInteger : (VInteger: Integer; VType:Longint); + vtBoolean : (VBoolean: Boolean); + vtChar : (VChar: Char); + vtExtended : (VExtended: PExtended); + vtString : (VString: PShortString); + vtPointer : (VPointer: Pointer); + vtPChar : (VPChar: PChar); + vtObject : (VObject: TObject); + vtClass : (VClass: TClass); + // vtWideChar : (VWideChar: WideChar); + // vtPWideChar : (VPWideChar: PWideChar); + vtAnsiString : (VAnsiString: Pointer); + // vtCurrency : (VCurrency: PCurrency); + // vtVariant : (VVariant: PVariant); + // vtInterface : (VInterface: Pointer); + // vtWideString : (VWideString: Pointer); + vtInt64 : (VInt64: PInt64); + vtQWord : (VQWord: PQWord); + end; +} + +procedure testit2 (args: array of byte); +begin +end; + +Procedure Testit (Args: Array of const); + +Var I : longint; + +begin + If High(Args)<0 then + begin + Writeln ('No aguments'); + exit; + end; + Write ('Got '); Write (High(Args)+1); Writeln(' arguments :'); + For i:=0 to High(Args) do + begin + write ('Argument '); write(i); write(' has type '); + case Args[i].vtype of + vtinteger : begin Write ('Integer, Value :'); Writeln(args[i].vinteger); end; + vtboolean : begin Write ('Boolean, Value :'); Writeln(args[i].vboolean); end; + vtchar : begin Write ('Char, value : '); Writeln(args[i].vchar); end; + vtextended : begin Write ('Extended, value : '); Writeln(args[i].VExtended^); end; + vtString : begin Write ('ShortString, value :'); Writeln(unicodestring(args[i].VString^)); end; + vtPointer : begin Write ('Pointer, toString : '); if assigned(Args[i].VPointer) then Writeln(JLString(JLObject(Args[i].VPointer).toString)) else writeln('nil') end; + vtPChar : begin Write ('PCHar, value : '); Writeln(unicodestring(Ansistring(Args[i].VPChar))); end; + vtObject : begin Write ('Object, toString : '); if assigned(Args[i].VObject) then Writeln(JLString(Args[i].VObject.toString)) else writeln('nil') end; + vtClass : begin Write ('Class reference, toString : '); Writeln(JLString(JLClass(Args[i].VClass).toString)); end; + vtAnsiString : begin Write ('AnsiString, value :'); Writeln(unicodestring(AnsiString(Args[I].VAnsiString))); end; + +{ + vtWideChar : (VWideChar: WideChar); + vtPWideChar : (VPWideChar: PWideChar); + vtCurrency : (VCurrency: PCurrency); + vtVariant : (VVariant: PVariant); + vtInterface : (VInterface: Pointer); + vtWideString : (VWideString: Pointer); +} + vtInt64 : begin Write ('Int64, value : '); Writeln(args[i].VInt64^); end; + vtQWord : begin Write ('QWord, value : '); Writeln(int64(args[i].VQWord^)); end; + else + begin Write ('(Unknown) : '); Writeln(args[i].vtype); end; + end; + end; +end; + +Const P1 : Pchar = 'Eerste Pchar'; + p2 : Pchar = 'Tweede pchar'; + +Var ObjA,ObjB : TObject; + ACLass,BClass : TClass; + S,T : AnsiString; + +begin + ObjA:=TObject.Create; + ObjB:=TObject.Create; + AClass:=TObject; + S:='Ansistring 1'; + T:='AnsiString 2'; + Write ('Size of VarRec : '); Writeln(Sizeof(TVarRec)); + Testit ([]); + Testit ([1,2]); + Testit (['A','B']); + Testit ([TRUE,FALSE,TRUE]); + Testit (['String','Another string']); + Testit ([S,T]) ; + Testit ([P1,P2]); + Testit ([@testit,Nil]); + Testit ([ObjA,ObjB]); + Testit ([1.234,1.234]); + TestIt ([AClass]); + TestIt ([QWord(1234)]); + TestIt ([Int64(1234)]); + TestIt ([Int64(12341234)*1000000000+Int64(12341234)]); + + TestIt2 ([]); + TestIt2 ([1,2]); +end. diff --git a/tests/test/jvm/tarray3.pp b/tests/test/jvm/tarray3.pp new file mode 100644 index 0000000000..ed36400096 --- /dev/null +++ b/tests/test/jvm/tarray3.pp @@ -0,0 +1,185 @@ +program tarray3; + +{$modeswitch exceptions} + +uses + jdk15; + +{$macro on} +{$define write:=JLSystem.fout.print} +{$define writeln:=JLSystem.fout.println} + +{$j+} +{$P+} + +type + CharA4 = array [1..4] of char; + CharA6 = array [1..6] of char; + String4 = String[4]; + String5 = String[5]; + String6 = String[6]; + String8 = String[8]; + +const + car4_1 : CharA4 = 'ABCD'; + car4_2 : CharA4 = 'abcd'; + car6_1 : CharA6 = 'EFGHIJ'; + car6_2 : CharA6 = 'efghij'; + cst4_1 : String4 = 'ABCD'; + cst6_2 : string6 = 'EFGHIJ'; + cst8_1 : string8 = 'abcd'; + cst8_2 : string8 = 'efghij'; + +var + ar4_1, ar4_2 : CharA4; + ar6_1, ar6_2 : CharA6; + st4_1, st4_2 : string4; + st5_1, st5_2 : string5; + st6_1, st6_2 : string6; + st8_1, st8_2 : string8; + +const + has_errors : boolean = false; + + procedure error(const st : string); + begin + writeln(unicodestring('Error: '+st)); + has_errors:=true; + end; + + procedure testvalueconv(st : string4); + begin + writeln(unicodestring('st='+st)); + Write('Length(st)=');writeln(Length(st)); + If Length(st)>4 then + Error('string length too big in calling value arg'); + end; + + procedure testconstconv(const st : string4); + begin + writeln(unicodestring('st='+st)); + Write('Length(st)=');writeln(Length(st)); + If Length(st)>4 then + Error('string length too big in calling const arg'); + end; + + procedure testvarconv(var st : string4); + begin + writeln(unicodestring('st='+st)); + Write('Length(st)=');writeln(Length(st)); + If Length(st)>4 then + Error('string length too big in calling var arg'); + end; + +{ is global switch+ can't turn off here } +{P-} + procedure testvarconv2(var st : string4); + begin + writeln(unicodestring('st='+st)); + Write('Length(st)=');writeln(Length(st)); + If Length(st)>4 then + Error('string length too big in calling var arg without openstring'); + end; + +begin + { compare array of char to constant strings } + writeln(unicodestring('Testing if "'+car4_1+'" is equal to "'+cst4_1+'"')); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); + writeln(unicodestring('Testing if "'+car4_1+'" is equal to "ABCD"')); + if car4_1<>'ABCD' then + error('Comparison of array of char and constat string don''t work'); + writeln(unicodestring('Testing if "'+cst4_1+'" is equal to "ABCD"')); + if 'ABCD'<>cst4_1 then + error('Comparison of string and constant string don''t work'); + car4_1:='AB'#0'D'; + if car4_1='AB' then + writeln('Anything beyond a #0 is ignored') + else if car4_1='AB'#0'D' then + Writeln('Chars after #0 are not ignored') + else + Error('problems if #0 in array of char'); +{$ifdef FPC this is not allowed in BP !} + car4_1:=cst4_1; +{ if it is allowed then it must also work correctly !! } + writeln(unicodestring('Testing if "'+car4_1+'" is equal to "'+cst4_1+'"')); + if car4_1<>cst4_1 then + error('Comparison of array of char and string don''t work'); +{$ifdef test_known_problems} + if string4(car6_2)<>'efgh' then + error('typcasting to shorter strings leads to problems'); +{$endif} + ar4_2:='Test'; + ar4_1:=cst6_2; + if ar4_2<>'Test' then + error('overwriting beyond char array size'); + ar6_1:='Test'#0'T'; + st6_1:=ar6_1; + if (st6_1<>ar6_1) or (st6_1='Test') then + error('problems with #0'); + ar6_1:='AB'; + if ar6_1='AB'#0't'#0'T' then + Error('assigning strings to array of char does not zero end of array if string is shorter'); + if ar6_1='AB'#0#0#0#0 then + writeln('assigning shorter strings to array of char does zero rest of array') + else + error('assigning "AB" to ar6_1 gives '+ar6_1); +{$endif} + cst8_1:=car4_1; +{ if it is allowed then it must also work correctly !! } + writeln(unicodestring('Testing if "'+car4_1+'" is equal to "'+cst8_1+'"')); + if car4_1<>cst8_1 then + error('Comparison of array of char and string don''t work'); + st4_2:='Test'; + st4_1:=car6_1; + if (st4_2<>'Test') or (st4_1<>'EFGH') then + error('problems when copying long char array to shorter string'); + testvalueconv('AB'); + testvalueconv('ABCDEFG'); + testvalueconv(car4_1); + testvalueconv(car6_1); +(* + getmem(pc+256); + pc:='Long Test'; +{$ifdef FPC this is not allowed in BP !} + testvalueconv(pc); +{$endif def FPC this is not allowed in BP !} +*) + testconstconv('AB'); +{$ifdef test_known_problems} + testconstconv('ABCDEFG'); +{$endif} + testconstconv(st4_1); +{$ifdef test_known_problems} + testconstconv(cst6_2); +{$endif} +{$ifdef FPC this is not allowed in BP !} +(* +{$ifdef test_known_problems} + testconstconv(pc); +{$endif} +*) +{$endif def FPC this is not allowed in BP !} + testvarconv(st4_2); + testvarconv(cst4_1); +{$ifdef FPC this is not allowed in BP !} +{$ifdef test_known_problems} + testvarconv(st6_1); + testvarconv(cst8_1); +{$endif} +{$endif def FPC this is not allowed in BP !} + { testvarconv(pc); this one fails at compilation } + testvarconv2(st4_2); + testvarconv2(cst4_1); +{$ifdef FPC this is not allowed in BP !} +{$ifdef test_known_problems} + testvarconv2(st6_1); + testvarconv2(cst8_1); +{$endif} +{$endif def FPC this is not allowed in BP !} + if has_errors then + begin + writeln(unicodestring('There are still problems with arrays of char')); + raise JLException.Create; + end; +end. diff --git a/tests/test/jvm/tbyte.pp b/tests/test/jvm/tbyte.pp new file mode 100644 index 0000000000..f081d3e73f --- /dev/null +++ b/tests/test/jvm/tbyte.pp @@ -0,0 +1,19 @@ +program tbyte; + +{$mode delphi} + +uses + jdk15; + +function test: longint; +var + a : longword; +begin + a := 123456789; + result := JLInteger.Create(Byte(a)).intValue; +end; + +begin + if test<>21 then + raise JLException.create('boe!'); +end. diff --git a/tests/test/jvm/tbytearrres.pp b/tests/test/jvm/tbytearrres.pp new file mode 100644 index 0000000000..24e278081d --- /dev/null +++ b/tests/test/jvm/tbytearrres.pp @@ -0,0 +1,37 @@ +program tbytearrres; + +{$mode delphi} + +uses + jdk15; + +type + ByteArray = array of byte; + +function GetUInt32(Src: array of byte; Offset : integer) : cardinal; +begin + result:=src[offset]; +end; + +function JByteArrayToByteArray(A : Arr1jbyte; Start: integer = 0; Count : integer = -1) : ByteArray; +var + i: longint; +begin + if count=-1 then + count:=length(a); + setlength(result,count); + for i:=start to start+count-1 do + result[i-start]:=a[i]; +end; + +function AddressToInt(X : JNInetAddress) : Cardinal; +begin + result := GetUInt32(JByteArrayToByteArray(X.getAddress()), 0); +end; + +var + c: cardinal; +begin + c:=AddressToInt(JNInetAddress.getLocalHost); + JLSystem.fout.println(int64(c)); +end. diff --git a/tests/test/jvm/tclassproptest.pp b/tests/test/jvm/tclassproptest.pp new file mode 100644 index 0000000000..680e9316eb --- /dev/null +++ b/tests/test/jvm/tclassproptest.pp @@ -0,0 +1,32 @@ +program tclassproptest; + +{$mode objfpc} + +uses + jdk15; + +type + tclassprop = class + strict private + class var fx: longint; + public + class property x: longint read fx write fx; + class procedure test(l: longint); + end; + +class procedure tclassprop.test(l: longint); + begin + if fx<>l then + raise jlexception.create('test 1 error'); + end; + + +var + c: tclassprop; +begin + c:=tclassprop.create; + c.x:=123; + c.test(123); + if c.x<>123 then + raise jlexception.create('test 2 error'); +end. diff --git a/tests/test/jvm/tcnvstr1.pp b/tests/test/jvm/tcnvstr1.pp new file mode 100644 index 0000000000..164c37a9e9 --- /dev/null +++ b/tests/test/jvm/tcnvstr1.pp @@ -0,0 +1,619 @@ +program tcnvstr1; + +{****************************************************************} +{ CODE GENERATOR TEST PROGRAM } +{ Copyright (c) 2002, Carl Eric Codere } +{****************************************************************} +{ NODE TESTED : secondtypeconvert() -> second_string_string } +{****************************************************************} +{ PRE-REQUISITES: secondload() } +{ secondassign() } +{ secondtypeconv() } +{****************************************************************} +{ DEFINES: } +{ FPC = Target is FreePascal compiler } +{****************************************************************} +{ REMARKS: Same type short conversion is not tested, except for } +{ shortstrings , since it requires special handling. } +{ } +{ } +{****************************************************************} + +{$ifdef fpc} +{$mode objfpc} + {$ifndef ver1_0} + {$define haswidestring} + {$endif} +{$else} + {$ifndef ver70} + {$define haswidestring} + {$endif} +{$endif} + +{$define hasshortstring} + +uses + jdk15; +{$H+} + +{$macro on} +{$define writeln:=JLSystem.fout.println} +{$define write:=JLSystem.fout.print} + +const + { exactly 255 characters in length } + BIG_STRING = +' This is a small text documentation to verify the validity of'+ +' the string conversion routines. Of course the conversion routines'+ +' should normally work like a charm, and this can only test that there'+ +' aren''t any problems with maximum length strings. This fix!'; + { < 255 characters in length } + SMALL_STRING = 'This is a small hello!'; + { > 255 characters in length } + HUGE_STRING_END = ' the goal of this experiment'; + HUGE_STRING = +' This is a huge text documentation to verify the validity of'+ +' the string conversion routines. Of course the conversion routines'+ +' should normally work like a charm, and this can only test that there'+ +' aren''t any problems with maximum length strings. I hope you understand'+ +HUGE_STRING_END; + EMPTY_STRING = ''; + +type + shortstr = string[127]; +var +{$ifdef hasshortstring} + s2: shortstr; +{$endif} + str_ansi: ansistring; +{$ifdef hasshortstring} + str_short: shortstring; +{$endif} +{$ifdef haswidestring} + str_wide : widestring; +{$endif} + + +procedure fail; + begin + Raise JLException.create('failure'); + end; + +{$ifdef hasshortstring} +procedure test_ansi_to_short; +var + p: pchar; +begin + {************************************************************************} + { ansistring -> shortstring } + {************************************************************************} + WriteLn('Test ansistring -> shortstring'); + { ansistring -> shortstring } + str_short := ''; + str_ansi:=''; + str_ansi := SMALL_STRING; + str_short:=str_ansi; + Write('small ansistring -> shortstring...'); + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + str_short := ''; + str_ansi:=''; + str_ansi := EMPTY_STRING; + str_short:=str_ansi; + Write('empty ansistring -> shortstring...'); + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + + str_short := ''; + str_ansi:=''; + str_ansi := BIG_STRING; + str_short:=str_ansi; + Write('big ansistring -> shortstring...'); + jlsystem.fout.println; + jlsystem.fout.println('const: '+BIG_STRING); + jlsystem.fout.println('ansi : '+unicodestring(str_ansi)); + jlsystem.fout.println('short: '+unicodestring(str_short)); + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + + Write('huge ansistring -> shortstring...'); + str_short := ''; + str_ansi:=''; + str_ansi := HUGE_STRING; + str_short:=str_ansi; + { Delphi 3/Delphi 6 does not consider these as the same string } + if str_short <> str_ansi then + WriteLn('Success.') + else + fail; +{} + s2 := ''; + str_ansi:=''; + str_ansi := SMALL_STRING; + s2:=str_ansi; + Write('small ansistring -> shortstring...'); + if s2 = str_ansi then + WriteLn('Success.') + else + fail; + + s2 := ''; + str_ansi:=''; + str_ansi := EMPTY_STRING; + s2:=str_ansi; + Write('empty ansistring -> shortstring...'); + if s2 = str_ansi then + WriteLn('Success.') + else + fail; + + str_ansi:=''; + p:=pchar(str_ansi); + Write('empty ansistring -> pchar...'); + if p^<>#0 then + fail; + if p[0]<>#0 then + fail + else + Writeln('Success'); + + s2 := ''; + str_ansi:=''; + str_ansi := BIG_STRING; + s2:=str_ansi; + Write('big ansistring -> shortstring...'); + { Should fail, since comparing different string lengths } + if s2 <> str_ansi then + WriteLn('Success.') + else + fail; + + + str_ansi := BIG_STRING; + Write('big ansistring -> pchar...'); + p:=pchar(str_ansi); + if p^<>' ' then + fail; + if p[0]<>' ' then + fail; + if length(p)<>length(BIG_STRING) then + fail + else + Writeln('Success'); + + + s2 := ''; + str_ansi:=''; + str_ansi := HUGE_STRING; + s2:=str_ansi; + Write('huge ansistring -> shortstring...'); + { Should fail, since comparing different string lengths } + if s2 <> str_ansi then + WriteLn('Success.') + else + fail; +end; + + +procedure test_short_to_short; +begin + {************************************************************************} + { shortstring -> shortstring } + {************************************************************************} + WriteLn('Test shortstring -> shortstring...'); + { shortstring -> shortstring } + str_short := ''; + s2:=''; + s2 := SMALL_STRING; + str_short:=s2; + Write('small shortstring -> shortstring...'); + if str_short = s2 then + WriteLn('Success.') + else + fail; + + str_short := ''; + s2:=''; + s2 := EMPTY_STRING; + str_short:=s2; + Write('empty shortstring -> shortstring...'); + if str_short = s2 then + WriteLn('Success.') + else + fail; + +{$ifdef fpc} +{ Delphi does not compile these } + str_short := ''; + s2:=''; + s2 := BIG_STRING; + str_short:=s2; + Write('big shortstring -> shortstring...'); + if str_short = s2 then + WriteLn('Success.') + else + fail; + + + str_short := ''; + s2:=''; + s2 := HUGE_STRING; + str_short:=s2; + Write('huge shortstring -> shortstring...'); + { Delphi 3/Delphi 6 does not consider these as the same string } + if str_short = s2 then + WriteLn('Success.') + else + fail; +{$endif} + + s2 := ''; + str_short:=''; + str_short := SMALL_STRING; + Write('small shortstring -> shortstring...'); + s2:=str_short; + if s2 = str_short then + WriteLn('Success.') + else + fail; + + s2 := ''; + str_short:=''; + str_short := EMPTY_STRING; + Write('empty shortstring -> shortstring...'); + s2:=str_short; + if s2 = str_short then + WriteLn('Success.') + else + fail; + + s2 := ''; + str_short:=''; + str_short := BIG_STRING; + Write('big shortstring -> shortstring...'); + s2:=str_short; + { Should fail, since comparing different string lengths } + if s2 <> str_short then + WriteLn('Success.') + else + fail; + +{$ifdef fpc} + s2 := ''; + str_short:=''; + writeln(length(ShortstringClass(@str_short).fdata)); + writeln(length(str_short)); + str_short := HUGE_STRING; + writeln(length(ShortstringClass(@str_short).fdata)); + writeln(length(str_short)); + Write('huge shortstring -> shortstring...'); + s2:=str_short; + writeln(unicodestring(s2)); + writeln(unicodestring(str_short)); + { Should fail, since comparing different string lengths } + if s2 <> str_short then + WriteLn('Success.') + else + fail; +{$endif} +end; + + +procedure test_short_to_ansi; +begin + {************************************************************************} + { shortstring -> ansistring } + {************************************************************************} + WriteLn('Test shortstring -> ansistring'); + Write('small shortstring -> ansistring...'); + { shortstring -> ansistring } + str_short := SMALL_STRING; + str_ansi:=str_short; + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + Write('empty shortstring -> ansistring...'); + str_short := EMPTY_STRING; + str_ansi:=str_short; + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + Write('big shortstring -> ansistring...'); + str_short := BIG_STRING; + str_ansi:=str_short; + if str_short = str_ansi then + WriteLn('Success.') + else + fail; + + Write('small shortstring -> ansistring...'); + { shortstring -> ansistring } + s2 := SMALL_STRING; + str_ansi:=s2; + if s2 = str_ansi then + WriteLn('Success.') + else + fail; + + Write('empty shortstring -> ansistring...'); + s2 := EMPTY_STRING; + str_ansi:=s2; + if s2 = str_ansi then + WriteLn('Success.') + else + fail; + +end; +{$endif} + +{$ifdef haswidestring} +procedure test_wide_to_ansi; +begin + {************************************************************************} + { widestring -> ansistring } + {************************************************************************} + WriteLn('Test widestring -> ansistring'); + Write('small widestring -> ansistring...'); + { widestring -> ansistring } + str_wide := SMALL_STRING; + str_ansi:=str_wide; + if str_wide = str_ansi then + WriteLn('Success.') + else + fail; + + Write('empty widestring -> ansistring...'); + str_wide := EMPTY_STRING; + str_ansi:=str_wide; + if str_wide = str_ansi then + WriteLn('Success.') + else + fail; + + Write('big widestring -> ansistring...'); + str_wide := BIG_STRING; + str_ansi:=str_wide; + if str_wide = str_ansi then + WriteLn('Success.') + else + fail; + + Write('huge widestring -> ansistring...'); + str_wide := HUGE_STRING; + str_ansi:=str_wide; + if str_wide = str_ansi then + WriteLn('Success.') + else + fail; + +end; + + +{$ifdef hasshortstring} +procedure test_short_to_wide; +begin + {************************************************************************} + { shortstring -> widestring } + {************************************************************************} + WriteLn('Test shortstring -> widestring'); + Write('small shortstring -> widestring...'); + { shortstring -> widestring } + str_short := SMALL_STRING; + str_wide:=str_short; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + + Write('empty shortstring -> widestring...'); + str_short := EMPTY_STRING; + str_wide:=str_short; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + + Write('big shortstring -> widestring...'); + str_short := BIG_STRING; + str_wide:=str_short; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + +{$ifdef hasshortstring} + Write('small shortstring -> widestring...'); + { shortstring -> widestring } + s2 := SMALL_STRING; + str_wide:=s2; + if s2 = str_wide then + WriteLn('Success.') + else + fail; + + Write('empty shortstring -> widestring...'); + s2 := EMPTY_STRING; + str_wide:=s2; + if s2 = str_wide then + WriteLn('Success.') + else + fail; +{$endif} +end; +{$endif} + +procedure test_ansi_to_wide; +begin + {************************************************************************} + { ansistring -> widestring } + {************************************************************************} + WriteLn('Test ansistring -> widestring'); + Write('small ansistring -> widestring...'); + { ansistring -> widestring } + str_ansi := SMALL_STRING; + str_wide:=str_ansi; + if str_ansi = str_wide then + WriteLn('Success.') + else + fail; + + Write('empty ansistring -> widestring...'); + str_ansi := EMPTY_STRING; + str_wide:=str_ansi; + if str_ansi = str_wide then + WriteLn('Success.') + else + fail; + + Write('big ansistring -> widestring...'); + str_ansi := BIG_STRING; + str_wide:=str_ansi; + if str_ansi = str_wide then + WriteLn('Success.') + else + fail; + +{$ifdef hasshortstring} + Write('small ansistring -> widestring...'); + { ansistring -> widestring } + s2 := SMALL_STRING; + str_wide:=s2; + if s2 = str_wide then + WriteLn('Success.') + else + fail; + + Write('empty ansistring -> widestring...'); + s2 := EMPTY_STRING; + str_wide:=s2; + if s2 = str_wide then + WriteLn('Success.') + else + fail; +{$endif hasshortstring} + +end; + + +{$ifdef hasshortstring} +procedure test_wide_to_short; +begin + {************************************************************************} + { widestring -> shortstring } + {************************************************************************} + WriteLn('Test widestring -> shortstring'); + { widestring -> shortstring } + str_short := ''; + str_wide:=''; + str_wide := SMALL_STRING; + Write('small widestring -> shortstring...'); + str_short:=str_wide; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + + str_short := ''; + str_wide:=''; + str_wide := EMPTY_STRING; + Write('empty widestring -> shortstring...'); + str_short:=str_wide; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + + + Write('big widestring -> shortstring...'); + str_short := ''; + str_wide:=''; + str_wide := BIG_STRING; + str_short:=str_wide; + if str_short = str_wide then + WriteLn('Success.') + else + fail; + + Write('huge widestring -> shortstring...'); + str_wide := HUGE_STRING; + str_short:=str_wide; + if str_short <> str_wide then + WriteLn('Success.') + else + fail; + +{} + Write('small widestring -> shortstring...'); + s2 := ''; + str_wide:=''; + str_wide := SMALL_STRING; + s2:=str_wide; + if s2 = str_wide then + WriteLn('Success.') + else + fail; + + Write('empty widestring -> shortstring...'); + s2 := ''; + str_wide:=''; + str_wide := EMPTY_STRING; + s2:=str_wide; + if s2 = str_wide then + WriteLn('Success.') + else + fail; + + Write('big widestring -> shortstring...'); + s2 := ''; + str_wide:=''; + str_wide := BIG_STRING; + s2:=str_wide; + if s2 <> str_wide then + WriteLn('Success.') + else + fail; + + Write('huge widestring -> shortstring...'); + s2 := ''; + str_wide:=''; + str_wide := HUGE_STRING; + s2:=str_wide; + if s2 <> str_wide then + WriteLn('Success.') + else + fail; +end; +{$endif} +{$endif} + +Begin +{$ifdef hasshortstring} + test_ansi_to_short; + test_short_to_short; + test_short_to_ansi; +{$endif} + { requires widestring support } +{$ifdef haswidestring} +{$ifdef hasshortstring} + test_short_to_wide; +{$endif} + test_ansi_to_wide; +{$ifdef hasshortstring} + test_wide_to_short; +{$endif} + test_wide_to_ansi; +{$endif} +End. diff --git a/tests/test/jvm/tcnvstr3.pp b/tests/test/jvm/tcnvstr3.pp new file mode 100644 index 0000000000..8a5773d35f --- /dev/null +++ b/tests/test/jvm/tcnvstr3.pp @@ -0,0 +1,156 @@ +program tcnvstr3; + +{ Type conversion program for char -> string } +{ possible types widechar -> widestring } +{ widechar -> shortstring } +{ widechar -> ansistring } +{ possible types char -> widestring } +{ char -> shortstring } +{ char -> ansistring } + +{$ifdef fpc} +{$mode objfpc} + {$ifndef ver1_0} + {$define haswidestring} + {$endif} +{$else} + {$ifndef ver70} + {$define haswidestring} + {$endif} +{$endif} + +uses jdk15; + +{$macro on} +{$define write:=JLSystem.fout.print} +{$define writeln:=JLSystem.fout.println} + +procedure fail; + begin + WriteLn('Failure!'); + raise JLException.Create; + end; + +var + str_ansi : ansistring; + str_short : shortstring; +{$ifdef haswidestring} + str_wide : widestring; + wc : widechar; +{$endif haswidestring} + c: char; + _result : boolean; +Begin + {********************** char/widechar -> shortstring *******************} + Write('widechar/char -> shortstring...'); + {* normal char *} + _result := true; + { empty string -> shortstring } + str_short := ''; + if str_short <> '' then + _result := false; + { constant char -> shortstring } + str_short := 'c'; + if str_short <> 'c' then + _result := false; + { normal char -> shortstring } + str_short := ''; + c:='c'; + str_short:=c; + if str_short <> 'c' then + _result := false; + {* wide char *} +{$ifdef haswidestring} + { constant char -> shortstring } + str_short := shortstring(widechar('c')); + if str_short <> 'c' then + _result := false; +{$endif} + { wide char -> shortstring } +{ This should not compile - at least it does not compile under Delphi } +{ str_short := ''; + wc:='c'; + str_short:=wc; + if str_short <> 'c' then + _result := false;} + + + if _result then + WriteLn('Success!') + else + fail; + {********************** char/widechar -> ansistring *******************} + Write('widechar/char -> ansistring...'); + {* normal char *} + _result := true; + { empty string -> ansistring } + str_ansi := ''; + if str_ansi <> '' then + _result := false; + { constant char -> ansistring } + str_ansi := 'c'; + if str_ansi <> 'c' then + _result := false; + { normal char -> ansistring } + str_ansi := ''; + c:='c'; + str_ansi:=c; + if str_ansi <> 'c' then + _result := false; + {* wide char *} +{$ifdef haswidestring} + { constant char -> ansistring } + str_ansi := widechar('c'); + if str_ansi <> 'c' then + _result := false; + { normal char -> ansistring } + str_ansi := ''; + wc:='c'; + str_ansi:=wc; + if str_ansi <> 'c' then + _result := false; +{$endif} + + if _result then + WriteLn('Success!') + else + fail; +{} +{$ifdef haswidestring} + {********************** char/widechar -> widestring *******************} + Write('widechar/char -> widestring...'); + {* normal char *} + _result := true; + { empty string -> widestring } + str_wide := ''; + if str_wide <> '' then + _result := false; + { constant char -> widestring } + str_wide := 'c'; + if str_wide <> 'c' then + _result := false; + { normal char -> widestring } + str_wide := ''; + c:='c'; + str_wide:=c; + if str_wide <> 'c' then + _result := false; + {* wide char *} + { constant char -> widestring } + str_wide := widechar('c'); + if str_wide <> 'c' then + _result := false; + { normal char -> widestring } + str_wide := ''; + wc:='c'; + str_wide:=wc; + if str_wide <> 'c' then + _result := false; + + + if _result then + WriteLn('Success!') + else + fail; +{$endif haswidestring} +end. diff --git a/tests/test/jvm/tconst.pp b/tests/test/jvm/tconst.pp new file mode 100644 index 0000000000..aa6fb2c0e6 --- /dev/null +++ b/tests/test/jvm/tconst.pp @@ -0,0 +1,40 @@ +program tconst; + +{$mode delphi} + +uses + jdk15; + +type + tc = class + const x: longint = 5; + end; + + ttypedconstrec = record + l: longint; + end; + +procedure test; overload; +const + l: longint = 1; + r: ttypedconstrec = (l: 5); +begin + if r.l<>5 then + raise jlexception.create('test1 r.l'); + if l<>1 then + raise jlexception.create('test1 l'); +end; + +procedure test(x: byte); overload; +const + { check that it gets a different mangled name } + l: longint = 4; +begin + if l<>4 then + raise jlexception.create('test1 l'); +end; + +begin + test; + test(3); +end. diff --git a/tests/test/jvm/tdefpara.pp b/tests/test/jvm/tdefpara.pp new file mode 100644 index 0000000000..1432738274 --- /dev/null +++ b/tests/test/jvm/tdefpara.pp @@ -0,0 +1,34 @@ +program tdefpara; + +{$mode delphi} + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$endif} + + +type + tc = class + fa: longint; + constructor create(a: longint = 1234); + end; + + tc2 = class(tc) + end; + +constructor tc.create(a: longint = 1234); +begin + fa:=a; +end; + +var + c: tc; +begin + c:=tc2.create; + if c.fa<>1234 then + raise jlexception.create('wrong overload'); +end. diff --git a/tests/test/jvm/tdynarrec.pp b/tests/test/jvm/tdynarrec.pp new file mode 100644 index 0000000000..c4ce952df5 --- /dev/null +++ b/tests/test/jvm/tdynarrec.pp @@ -0,0 +1,48 @@ +Program tdynarrec; + +{$mode objfpc} + +uses + jdk15; + +type + tdynrec = record + s: string[10]; + end; + + +procedure error(l: longint); +begin + JLSystem.fout.print('error: '); + JLSystem.fout.println(l); + raise jlexception.create('fatal'); +end; + +var + r1,r2: array of tdynrec; + rr: tdynrec; +begin + setlength(r1,5); + r2:=r1; + rr.s:='abc'; + r1[0]:=rr; + if r2[0].s<>'abc' then + error(0); + rr.s:='def'; + if r1[0].s<>'abc' then + error(1); + r1[1]:=rr; + if r1[0].s<>'abc' then + error(2); + setlength(r2,6); + if r1[0].s<>'abc' then + error(3); + if r2[0].s<>'abc' then + error(4); + if r2[1].s<>'def' then + error(3); + rr.s:='ghi'; + r1[0]:=rr; + if r2[0].s<>'abc' then + error(5); +end. diff --git a/tests/test/jvm/tenum.pp b/tests/test/jvm/tenum.pp new file mode 100644 index 0000000000..a5d1c61d7e --- /dev/null +++ b/tests/test/jvm/tenum.pp @@ -0,0 +1,84 @@ +program tenum; + +{$mode delphi} + +uses + uenum; + +const + cenum = mea; + +type + tenumclass = class + e: myenum; + constructor create; + end; + +constructor tenumclass.create; + begin + if e<>mea then + raise JLException.create('error create'); + end; + +function func: myenum; +begin + result:=cenum; +end; + +var + a: myenum; + b1,b2: myenumjumps; + l: longint; + arr: array[myenum] of byte; + c: tenumclass; + earr: array[1..4] of myenum; + dearr: array of myenum; +begin + c:=tenumclass.create; + if earr[1]<>mea then + raise JLException.create('error 0'); + setlength(dearr,1); + if dearr[0]<>mea then + raise JLException.create('error 0a'); + a:=cenum; + inc(a); + if ord(a)<>1 then + raise JLException.create('error 1'); + a:=succ(a); + if a<>mec then + raise JLException.create('error 2'); + + arr[a]:=123; + if arr[mec]<>123 then + raise JLException.create('error 2a'); + l:=0; + for a:=func to mec do + inc(l,ord(a)); + if l<>3 then + raise JLException.create('error 2b'); + if JLObject(mea).toString<>'mea' then + raise JLException.create('expected mea, got '+unicodestring(JLObject(mea).toString)); + + a:=mec; + case a of + mea..meb: + raise JLException.create('error 2c'); + mec: + ; + else + raise JLException.create('error 2d'); + end; + + + b1:=meja; + b2:=mejb; + if b1<=b2 then + raise JLException.create('error 3'); + b2:=mejc; + if b1>=b2 then + raise JLException.create('error 4'); + l:=-5; + b2:=myenumjumps(l); + if b2<>mejb then + raise JLException.create('error 5'); +end. diff --git a/tests/test/jvm/test.pp b/tests/test/jvm/test.pp new file mode 100644 index 0000000000..539722bf82 --- /dev/null +++ b/tests/test/jvm/test.pp @@ -0,0 +1,2164 @@ +{$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 + jdk15; + +{ 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; + 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<>123.125 then + exit; + + result:=-2; + d:=9876.0625; + l:=jlong(d); + d:=1.0; + d:=jdouble(l); + if d<>9876.0625 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. diff --git a/tests/test/jvm/testall.bat b/tests/test/jvm/testall.bat new file mode 100644 index 0000000000..998d2e1df9 --- /dev/null +++ b/tests/test/jvm/testall.bat @@ -0,0 +1,182 @@ +ppcjvm -O2 -g unsupported +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g testintf +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g nested +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g test +if %errorlevel% neq 0 exit /b %errorlevel% +javac -encoding utf-8 -cp ..\..\..\rtl\units\jvm-java;. JavaClass +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. JavaClass +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g sort +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. sort +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g classmeth +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. classmeth +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g classlist +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. classlist +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g testansi +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. testansi +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tcnvstr1 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tcnvstr1 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tcnvstr3 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tcnvstr3 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g testshort +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. testshort +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tarray2 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tarray2 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tarray3 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tarray3 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tnestproc +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tnestproc +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g outpara +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. outpara +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tbytearrres +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tbytearrres +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g forw +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tbyte +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tbyte +if %errorlevel% neq 0 exit /b %errorlevel% +del uenum.ppu +ppcjvm -O2 -g tenum +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tenum +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tprop +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tprop2 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tprop2 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tclassproptest +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tclassproptest +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tset3 -dproc +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tset3 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tset3 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tset3 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g taddset +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. taddset +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g taddsetint +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. taddsetint +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tformalpara +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tformalpara +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tvarpara +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tvarpara +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tpvar +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tpvar +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tpvardelphi +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tpvardelphi +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tpvarglobal +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tpvarglobal +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tpvarglobaldelphi +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tpvarglobaldelphi +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tvirtclmeth +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tvirtclmeth +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tdynarrec +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tdynarrec +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tconst +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tconst +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g twith +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. twith +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tint +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tint +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g ttrig +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. ttrig +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g ttrunc +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. ttrunc +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tset1 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tset1 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tabs +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tabs +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tintstr +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tintstr +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g trange1 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. trange1 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g trange2 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. trange2 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g trange3 +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. trange3 +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g tdefpara +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tdefpara +if %errorlevel% neq 0 exit /b %errorlevel% +ppcjvm -O2 -g getbit +if %errorlevel% neq 0 exit /b %errorlevel% +java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. getbit +if %errorlevel% neq 0 exit /b %errorlevel% diff --git a/tests/test/jvm/testall.sh b/tests/test/jvm/testall.sh new file mode 100755 index 0000000000..0b5b1d628f --- /dev/null +++ b/tests/test/jvm/testall.sh @@ -0,0 +1,96 @@ +#!/bin/bash + +set -ex + +ppcjvm -O2 -g unsupported +ppcjvm -O2 -g testintf +ppcjvm -O2 -g nested +ppcjvm -O2 -g test +javac -encoding utf-8 -cp ../../../rtl/units/jvm-java:. JavaClass.java +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. JavaClass +ppcjvm -O2 -g sort +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. sort +ppcjvm -O2 -g classmeth +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. classmeth +ppcjvm -O2 -g classlist +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. classlist +ppcjvm -O2 -g testansi +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. testansi +ppcjvm -O2 -g tcnvstr1 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tcnvstr1 +ppcjvm -O2 -g tcnvstr3 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tcnvstr3 +ppcjvm -O2 -g testshort +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. testshort +ppcjvm -O2 -g tarray2 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tarray2 +ppcjvm -O2 -g tarray3 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tarray3 +ppcjvm -O2 -g tnestproc +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tnestproc +ppcjvm -O2 -g outpara +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. outpara +ppcjvm -O2 -g tbytearrres +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tbytearrres +ppcjvm -O2 -g forw +ppcjvm -O2 -g tbyte +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tbyte +rm -f uenum.ppu +ppcjvm -O2 -g tenum +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tenum +ppcjvm -O2 -g tprop +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tprop +ppcjvm -O2 -g tprop2 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tprop2 +ppcjvm -O2 -g tclassproptest +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tclassproptest +ppcjvm -O2 -g tset3 -dproc +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tset3 +ppcjvm -O2 -g tset3 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tset3 +ppcjvm -O2 -g taddset +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. taddset +ppcjvm -O2 -g taddsetint +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. taddsetint +ppcjvm -O2 -g tformalpara +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tformalpara +ppcjvm -O2 -g tvarpara +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tvarpara +ppcjvm -O2 -g tpvar +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tpvar +ppcjvm -O2 -g tpvardelphi +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tpvardelphi +ppcjvm -O2 -g tpvarglobal +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tpvarglobal +ppcjvm -O2 -g tpvarglobaldelphi +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tpvarglobaldelphi +ppcjvm -O2 -g tvirtclmeth +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tvirtclmeth +ppcjvm -O2 -g tdynarrec +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tdynarrec +ppcjvm -O2 -g tconst +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tconst +ppcjvm -O2 -g twith +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. twith +ppcjvm -O2 -g tint +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tint +ppcjvm -O2 -g ttrig +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. ttrig +ppcjvm -O2 -g ttrunc +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. ttrunc +ppcjvm -O2 -g tset1 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tset1 +ppcjvm -O2 -g tabs +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tabs +ppcjvm -O2 -g tintstr +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tintstr +ppcjvm -O2 -g trange1 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. trange1 +ppcjvm -O2 -g trange2 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. trange2 +ppcjvm -O2 -g trange3 +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. trange3 +ppcjvm -O2 -g tdefpara +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tdefpara +ppcjvm -O2 -g getbit +java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. getbit diff --git a/tests/test/jvm/testansi.pp b/tests/test/jvm/testansi.pp new file mode 100644 index 0000000000..4dec633623 --- /dev/null +++ b/tests/test/jvm/testansi.pp @@ -0,0 +1,28 @@ +program testansi; + +{$mode delphi} + +procedure testansichars; +const + ansiconst = #0#1#2#3#4#5#6#7#8#9#10#11#12#13#14#15#16#17#18#19#20#21#22#23#24#25#26#27#28#29#30#31#32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47#48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63#64#65#66#67#68#69#70#71#72#73#74#75#76#77#78#79#80#81#82#83#84#85#86#87#88#89#90#91#92#93#94#95#96#97#98#99#100#101#102#103#104#105#106#107#108#109#110#111#112#113#114#115#116#117#118#119#120#121#122#123#124#125#126#127#128#129#130#131#132#133#134#135#136#137#138#139#140#141#142#143#144#145#146#147#148#149#150#151#152#153#154#155#156#157#158#159#160#161#162#163#164#165#166#167#168#169#170#171#172#173#174#175#176#177#178#179#180#181#182#183#184#185#186#187#188#189#190#191#192#193#194#195#196#197#198#199#200#201#202#203#204#205#206#207#208#209#210#211#212#213#214#215#216#217#218#219#220#221#222#223#224#225#226#227#228#229#230#231#232#233#234#235#236#237#238#239#240#241#242#243#244#245#246#247#248#249#250#251#252#253#254#255; +var + s: ansistring; + i: longint; +begin + s:=ansiconst; + for i:=1 to length(s) do + if ord(s[i])<>i-1 then + raise JLException.Create('wrong ascii contents'); + setlength(s,10); + for i:=1 to length(s) do + begin + if ord(s[i])<>i-1 then + raise JLException.Create('wrong ascii contents 2'); + if i>10 then + raise JLException.Create('ansistring too long'); + end; +end; + +begin + testansichars; +end. diff --git a/tests/test/jvm/testintf.pp b/tests/test/jvm/testintf.pp new file mode 100644 index 0000000000..8e592b7e90 --- /dev/null +++ b/tests/test/jvm/testintf.pp @@ -0,0 +1,78 @@ +{ %norun } + +{$mode objfpc} + +{$namespace org.freepascal.test} + +unit testintf; + +interface + +type + tinterface1 = interface + function test(l: longint): longint; + end; + + tinterface2 = interface + const + iconst = longint(4); + function test(b: byte): longint; + end; + + tinterface3 = interface(tinterface1,tinterface2) + end; + + tinterface4 = interface + function intf4test(i: int64): longint; + end; + + tintfclass = class(tinterface1,tinterface2,tinterface3) + constructor create; + function test(l: longint): longint;virtual;final; + function Test(b: byte): longint;virtual;final; + destructor destroy; override; + end; + + tintfclass2 = class(tintfclass,tinterface4) + constructor create; + function intf4test(i: int64): longint;virtual;final; + end; + +implementation + + uses + jdk15; + + constructor tintfclass.create; + begin + end; + + function tintfclass.Test(l: longint): longint; + begin + result:=l+1; + end; + + + function tintfclass.test(b: byte): longint; + begin + result:=b+2; + end; + + + destructor tintfclass.destroy; + begin + JLSystem.fout.println(555); + end; + + constructor tintfclass2.create; + begin + end; + + + function tintfclass2.intf4test(i: int64): longint; + begin + result:=i div 12345; + end; + + +end. diff --git a/tests/test/jvm/testshort.pp b/tests/test/jvm/testshort.pp new file mode 100644 index 0000000000..7e3db3d363 --- /dev/null +++ b/tests/test/jvm/testshort.pp @@ -0,0 +1,28 @@ +program testshort; + +{$mode delphi} +{$h-} + +procedure testansichars; +const + shortconst = #0#1#2#3#4#5#6#7#8#9#10#11#12#13#14#15#16#17#18#19#20#21#22#23#24#25#26#27#28#29#30#31#32#33#34#35#36#37#38#39#40#41#42#43#44#45#46#47#48#49#50#51#52#53#54#55#56#57#58#59#60#61#62#63#64#65#66#67#68#69#70#71#72#73#74#75#76#77#78#79#80#81#82#83#84#85#86#87#88#89#90#91#92#93#94#95#96#97#98#99#100#101#102#103#104#105#106#107#108#109#110#111#112#113#114#115#116#117#118#119#120#121#122#123#124#125#126#127#128#129#130#131#132#133#134#135#136#137#138#139#140#141#142#143#144#145#146#147#148#149#150#151#152#153#154#155#156#157#158#159#160#161#162#163#164#165#166#167#168#169#170#171#172#173#174#175#176#177#178#179#180#181#182#183#184#185#186#187#188#189#190#191#192#193#194#195#196#197#198#199#200#201#202#203#204#205#206#207#208#209#210#211#212#213#214#215#216#217#218#219#220#221#222#223#224#225#226#227#228#229#230#231#232#233#234#235#236#237#238#239#240#241#242#243#244#245#246#247#248#249#250#251#252#253#254; +var + s: shortstring; + i: longint; +begin + setlength(s,0); + setlength(s,5); + s:=shortconst; + for i:=1 to length(s) do + if ord(s[i])<>i-1 then + raise JLException.Create('wrong ascii contents'); + for i:=1 to length(s) do + s[i]:=chr(i); + for i:=1 to length(s) do + if ord(s[i])<>i then + raise JLException.Create('wrong ascii contents (2)'); +end; + +begin + testansichars; +end. diff --git a/tests/test/jvm/tformalpara.pp b/tests/test/jvm/tformalpara.pp new file mode 100644 index 0000000000..a94387e3fa --- /dev/null +++ b/tests/test/jvm/tformalpara.pp @@ -0,0 +1,679 @@ +unit tformalpara; + +{$mode delphi} + +interface + +procedure main(args: array of string); + +implementation + +uses + jdk15; + +type + tc = class + end; + +procedure freeandnil(var obj); +begin + obj:=nil; +end; + +procedure test; +var + c: tc; +begin + c:=tc.create; + freeandnil(c); + if assigned(c) then + raise jlexception.create('help'); +end; + +type + tformalkind = (fboolean,fbyte,fsmallint,fcardinal,fint64,fchar,fwidechar,fsingle,fdouble,fsetint,fsetenum,frec,fshortstring,funicodestring,farrbyte,farrset); + + tsetint = set of 30..40; + tsetenum = set of tformalkind; + tarrbyte = array[4..6] of byte; + tarrset = array[1..2] of tsetint; + trec = record + a: longint; + b: array[3..4] of ansistring; + end; + +const + cbooleanin: boolean = true; + cbytein: byte = 35; + csmallintin: smallint = 1234; + ccardinalin: cardinal = $1234567; + cint64in: int64 = $deadcafebabe; + ccharin: ansichar = 'S'; + cwidecharin: widechar = 'U'; + csinglein: single = 1234.5; + cdoublein: double = 1239643.75; + csetintin: tsetint = [36..39]; + csetenumin: tsetenum = [fsmallint,fint64,funicodestring]; + crecin: trec = (a:98765; b:('abc','def')); + cshortstringin: shortstring = 'greaT'; + cunicodestringin: unicodestring = 'a bit longer!'; + carrbytein: tarrbyte = (4,2,5); + carrsetin: tarrset = ([31,33,37],[]); + + cbooleanout: boolean = false; + cbyteout: byte = 128; + csmallintout: smallint = 4321; + ccardinalout: cardinal = $7654321; + cint64out: int64 = $B4B3154713; + ccharout: ansichar = 's'; + cwidecharout: widechar = 'u'; + csingleout: single = 4321.5; + cdoubleout: double = 9876543.75; + csetintout: tsetint = [31..36]; + csetenumout: tsetenum = [fbyte]; + crecout: trec = (a:4365246; b:('cbax','iiiiii')); + cshortstringout: shortstring = 'tiny'; + cunicodestringout: unicodestring = 'yet another bit longer!'; + carrbyteout: tarrbyte = (6,6,6); + carrsetout: tarrset = ([30,31],[33..38]); + +procedure testformalvar(var x; typ: tformalkind); + var + i: longint; + begin + case typ of + fboolean: + begin + if cbooleanin<>boolean(x) then + raise jlexception.create('boolean in'); + x:=cbooleanout; + end; + fbyte: + begin + if cbytein<>byte(x) then + raise jlexception.create('byte in'); + x:=cbyteout; + end; + fsmallint: + begin + if csmallintin<>smallint(x) then + raise jlexception.create('smallint in'); + x:=csmallintout; + end; + fcardinal: + begin + if ccardinalin<>cardinal(x) then + raise jlexception.create('cardinal in'); + x:=ccardinalout; + end; + fint64: + begin + if cint64in<>int64(x) then + raise jlexception.create('int64 in'); + x:=cint64out; + end; + fchar: + begin + if ccharin<>char(x) then + raise jlexception.create('char in'); + x:=ccharout; + end; + fwidechar: + begin + if cwidecharin<>widechar(x) then + raise jlexception.create('widechar in'); + x:=cwidecharout; + end; + fsingle: + begin + if csinglein<>single(x) then + raise jlexception.create('single in'); + x:=csingleout; + end; + fdouble: + begin + if cdoublein<>double(x) then + raise jlexception.create('double in'); + x:=cdoubleout; + end; + fsetint: + begin + if csetintin<>tsetint(x) then + raise jlexception.create('setint in'); + x:=csetintout; + end; + fsetenum: + begin + if csetenumin<>tsetenum(x) then + raise jlexception.create('setenum in'); + x:=csetenumout; + end; + frec: + begin + if crecin.a<>trec(x).a then + raise jlexception.create('rec.a in'); + if crecin.b[3]<>trec(x).b[3] then + raise jlexception.create('rec.b[3] in'); + if crecin.b[4]<>trec(x).b[4] then + raise jlexception.create('rec.b[4] in'); + x:=crecout; + end; + fshortstring: + begin + if cshortstringin<>shortstring(x) then + raise jlexception.create('shortstring in'); + x:=cshortstringout; + end; + funicodestring: + begin + if cunicodestringin<>unicodestring(x) then + raise jlexception.create('unicodestring in'); + x:=cunicodestringout; + end; + farrbyte: + begin + for i:=low(carrbytein) to high(carrbytein) do + if carrbytein[i]<>tarrbyte(x)[i] then + raise jlexception.create('arrbyte in'); + x:=carrbyteout; + end; + farrset: + begin + for i:=low(carrsetin) to high(carrsetin) do + if carrsetin[i]<>tarrset(x)[i] then + raise jlexception.create('arrset in'); + x:=carrsetout; + end; + end; + end; + + +procedure testformalout(out x; typ: tformalkind); + var + i: longint; + begin + case typ of + fboolean: + begin + x:=cbooleanout; + end; + fbyte: + begin + x:=cbyteout; + end; + fsmallint: + begin + x:=csmallintout; + end; + fcardinal: + begin + x:=ccardinalout; + end; + fint64: + begin + x:=cint64out; + end; + fchar: + begin + x:=ccharout; + end; + fwidechar: + begin + x:=cwidecharout; + end; + fsingle: + begin + x:=csingleout; + end; + fdouble: + begin + x:=cdoubleout; + end; + fsetint: + begin + x:=csetintout; + end; + fsetenum: + begin + x:=csetenumout; + end; + frec: + begin + { fpc only decreases the reference, it doesn't finalize/init with empty/nil + if ''<>trec(x).b[3] then + raise jlexception.create('out rec.b[3] in'); + if ''<>trec(x).b[4] then + raise jlexception.create('out rec.b[4] in'); + } + x:=crecout; + end; + fshortstring: + begin + x:=cshortstringout; + end; + funicodestring: + begin + { fpc only decreases the reference, it doesn't finalize/init with if ''<>unicodestring(x) then + raise jlexception.create('out unicodestring in'); + } + x:=cunicodestringout; + end; + farrbyte: + begin + x:=carrbyteout; + end; + farrset: + begin + x:=carrsetout; + end; + end; + end; + + +procedure testformalconst(const x; typ: tformalkind); + var + i: longint; + begin + case typ of + fboolean: + begin + if cbooleanin<>boolean(x) then + raise jlexception.create('const boolean in'); + end; + fbyte: + begin + if cbytein<>byte(x) then + raise jlexception.create('const byte in'); + end; + fsmallint: + begin + if csmallintin<>smallint(x) then + raise jlexception.create('const smallint in'); + end; + fcardinal: + begin + if ccardinalin<>cardinal(x) then + raise jlexception.create('const cardinal in'); + end; + fint64: + begin + if cint64in<>int64(x) then + raise jlexception.create('const int64 in'); + end; + fchar: + begin + if ccharin<>char(x) then + raise jlexception.create('const char in'); + end; + fwidechar: + begin + if cwidecharin<>widechar(x) then + raise jlexception.create('const widechar in'); + end; + fsingle: + begin + if csinglein<>single(x) then + raise jlexception.create('const single in'); + end; + fdouble: + begin + if cdoublein<>double(x) then + raise jlexception.create('const double in'); + end; + fsetint: + begin + if csetintin<>tsetint(x) then + raise jlexception.create('const setint in'); + end; + fsetenum: + begin + if csetenumin<>tsetenum(x) then + raise jlexception.create('const setenum in'); + end; + frec: + begin + if crecin.a<>trec(x).a then + raise jlexception.create('const rec.a in'); + if crecin.b[3]<>trec(x).b[3] then + raise jlexception.create('const rec.b[3] in'); + if crecin.b[4]<>trec(x).b[4] then + raise jlexception.create('const rec.b[4] in'); + end; + fshortstring: + begin + if cshortstringin<>shortstring(x) then + raise jlexception.create('const shortstring in'); + end; + funicodestring: + begin + if cunicodestringin<>unicodestring(x) then + raise jlexception.create('const unicodestring in'); + end; + farrbyte: + begin + for i:=low(carrbytein) to high(carrbytein) do + if carrbytein[i]<>tarrbyte(x)[i] then + raise jlexception.create('const arrbyte in'); + end; + farrset: + begin + for i:=low(carrsetin) to high(carrsetin) do + if carrsetin[i]<>tarrset(x)[i] then + raise jlexception.create('const arrset in'); + end; + end; + end; + + +procedure testformalvars; + var + vboolean: boolean; + vbyte: byte; + vsmallint: smallint; + vcardinal: cardinal; + vint64: int64; + vchar: char; + vwidechar: widechar; + vsingle: single; + vdouble: double; + vsetint: tsetint; + vsetenum: tsetenum; + vrec: trec; + vshortstring: shortstring; + vunicodestring: unicodestring; + varrbyte: tarrbyte; + varrset: tarrset; + i: longint; + begin + vboolean:=cbooleanin; + testformalvar(vboolean,fboolean); + if vboolean<>cbooleanout then + raise jlexception.create('boolean out'); + vbyte:=cbytein; + testformalvar(vbyte,fbyte); + if vbyte<>cbyteout then + raise jlexception.create('byte out'); + vsmallint:=csmallintin; + testformalvar(vsmallint,fsmallint); + if vsmallint<>csmallintout then + raise jlexception.create('smallint out'); + vunicodestring:=widechar(csmallintin); + testformalvar(smallint(vunicodestring[1]),fsmallint); + if smallint(vunicodestring[1])<>csmallintout then + raise jlexception.create('stringsmallint out'); + vcardinal:=ccardinalin; + testformalvar(vcardinal,fcardinal); + if vcardinal<>ccardinalout then + raise jlexception.create('cardinal out'); + vint64:=cint64in; + testformalvar(vint64,fint64); + if vint64<>cint64out then + raise jlexception.create('int64 out'); + vchar:=ccharin; + testformalvar(vchar,fchar); + if vchar<>ccharout then + raise jlexception.create('char out'); + vwidechar:=cwidecharin; + testformalvar(vwidechar,fwidechar); + if vwidechar<>cwidecharout then + raise jlexception.create('widechar out'); + vunicodestring:=cwidecharin; + testformalvar(vunicodestring[1],fwidechar); + if vunicodestring[1]<>cwidecharout then + raise jlexception.create('stringwidechar out'); + vsingle:=csinglein; + testformalvar(vsingle,fsingle); + if vsingle<>csingleout then + raise jlexception.create('single out'); + vdouble:=cdoublein; + testformalvar(vdouble,fdouble); + if vdouble<>cdoubleout then + raise jlexception.create('double out'); + vsetint:=csetintin; + testformalvar(vsetint,fsetint); + if vsetint<>csetintout then + raise jlexception.create('setint out'); + vsetenum:=csetenumin; + testformalvar(vsetenum,fsetenum); + if vsetenum<>csetenumout then + raise jlexception.create('setenum out'); + vrec:=crecin; + testformalvar(vrec,frec); + if crecout.a<>vrec.a then + raise jlexception.create('rec.a out'); + if crecout.b[3]<>vrec.b[3] then + raise jlexception.create('rec.b[3] out'); + if crecout.b[4]<>vrec.b[4] then + raise jlexception.create('rec.b[4] out'); + vshortstring:=cshortstringin; + testformalvar(vshortstring,fshortstring); + if vshortstring<>cshortstringout then + raise jlexception.create('shortstring out'); + vunicodestring:=cunicodestringin; + testformalvar(vunicodestring,funicodestring); + if vunicodestring<>cunicodestringout then + raise jlexception.create('unicodestring out'); + varrbyte:=carrbytein; + testformalvar(varrbyte,farrbyte); + for i:=low(carrbyteout) to high(carrbyteout) do + if carrbyteout[i]<>varrbyte[i] then + raise jlexception.create('arrbyte out'); + varrset:=carrsetin; + testformalvar(varrset,farrset); + for i:=low(carrsetout) to high(carrsetout) do + if varrset[i]<>carrsetout[i] then + raise jlexception.create('arrset out'); + end; + + +procedure testformalouts; + var + vboolean: boolean; + vbyte: byte; + vsmallint: smallint; + vcardinal: cardinal; + vint64: int64; + vchar: char; + vwidechar: widechar; + vsingle: single; + vdouble: double; + vsetint: tsetint; + vsetenum: tsetenum; + vrec: trec; + vshortstring: shortstring; + vunicodestring: unicodestring; + varrbyte: tarrbyte; + varrset: tarrset; + i: longint; + begin + vboolean:=cbooleanin; + testformalout(vboolean,fboolean); + if vboolean<>cbooleanout then + raise jlexception.create('out boolean out'); + vbyte:=cbytein; + testformalout(vbyte,fbyte); + if vbyte<>cbyteout then + raise jlexception.create('out byte out'); + vsmallint:=csmallintin; + testformalout(vsmallint,fsmallint); + if vsmallint<>csmallintout then + raise jlexception.create('out smallint out'); + vunicodestring:=widechar(csmallintin); + testformalout(smallint(vunicodestring[1]),fsmallint); + if smallint(vunicodestring[1])<>csmallintout then + raise jlexception.create('out stringsmallint out'); + vcardinal:=ccardinalin; + testformalout(vcardinal,fcardinal); + if vcardinal<>ccardinalout then + raise jlexception.create('out cardinal out'); + vint64:=cint64in; + testformalout(vint64,fint64); + if vint64<>cint64out then + raise jlexception.create('out int64 out'); + vchar:=ccharin; + testformalout(vchar,fchar); + if vchar<>ccharout then + raise jlexception.create('out char out'); + vwidechar:=cwidecharin; + testformalout(vwidechar,fwidechar); + if vwidechar<>cwidecharout then + raise jlexception.create('out widechar out'); + vunicodestring:=cwidecharin; + testformalout(vunicodestring[1],fwidechar); + if vunicodestring[1]<>cwidecharout then + raise jlexception.create('out stringwidechar out'); + vsingle:=csinglein; + testformalout(vsingle,fsingle); + if vsingle<>csingleout then + raise jlexception.create('out single out'); + vdouble:=cdoublein; + testformalout(vdouble,fdouble); + if vdouble<>cdoubleout then + raise jlexception.create('out double out'); + vsetint:=csetintin; + testformalout(vsetint,fsetint); + if vsetint<>csetintout then + raise jlexception.create('out setint out'); + vsetenum:=csetenumin; + testformalout(vsetenum,fsetenum); + if vsetenum<>csetenumout then + raise jlexception.create('out setenum out'); + vrec:=crecin; + testformalout(vrec,frec); + if crecout.a<>vrec.a then + raise jlexception.create('out rec.a out'); + if crecout.b[3]<>vrec.b[3] then + raise jlexception.create('out rec.b[3] out'); + if crecout.b[4]<>vrec.b[4] then + raise jlexception.create('out rec.b[4] out'); + vshortstring:=cshortstringin; + testformalout(vshortstring,fshortstring); + if vshortstring<>cshortstringout then + raise jlexception.create('out shortstring out'); + vunicodestring:=cunicodestringin; + testformalout(vunicodestring,funicodestring); + if vunicodestring<>cunicodestringout then + raise jlexception.create('out unicodestring out'); + varrbyte:=carrbytein; + testformalout(varrbyte,farrbyte); + for i:=low(carrbyteout) to high(carrbyteout) do + if carrbyteout[i]<>varrbyte[i] then + raise jlexception.create('out arrbyte out'); + varrset:=carrsetin; + testformalout(varrset,farrset); + for i:=low(carrsetout) to high(carrsetout) do + if varrset[i]<>carrsetout[i] then + raise jlexception.create('out arrset out'); + end; + + +procedure testformalconsts; + var + vboolean: boolean; + vbyte: byte; + vsmallint: smallint; + vcardinal: cardinal; + vint64: int64; + vchar: char; + vwidechar: widechar; + vsingle: single; + vdouble: double; + vsetint: tsetint; + vsetenum: tsetenum; + vrec: trec; + vshortstring: shortstring; + vunicodestring: unicodestring; + varrbyte: tarrbyte; + varrset: tarrset; + i: longint; + begin + vboolean:=cbooleanin; + testformalconst(vboolean,fboolean); + if vboolean<>cbooleanin then + raise jlexception.create('const boolean out'); + vbyte:=cbytein; + testformalconst(vbyte,fbyte); + if vbyte<>cbytein then + raise jlexception.create('const byte out'); + vsmallint:=csmallintin; + testformalconst(vsmallint,fsmallint); + if vsmallint<>csmallintin then + raise jlexception.create('const smallint out'); + vunicodestring:=widechar(csmallintin); + testformalconst(smallint(vunicodestring[1]),fsmallint); + if smallint(vunicodestring[1])<>csmallintin then + raise jlexception.create('const stringsmallint out'); + vcardinal:=ccardinalin; + testformalconst(vcardinal,fcardinal); + if vcardinal<>ccardinalin then + raise jlexception.create('const cardinal out'); + vint64:=cint64in; + testformalconst(vint64,fint64); + if vint64<>cint64in then + raise jlexception.create('const int64 out'); + vchar:=ccharin; + testformalconst(vchar,fchar); + if vchar<>ccharin then + raise jlexception.create('const char out'); + vwidechar:=cwidecharin; + testformalconst(vwidechar,fwidechar); + if vwidechar<>cwidecharin then + raise jlexception.create('const widechar out'); + vunicodestring:=cwidecharin; + testformalconst(vunicodestring[1],fwidechar); + if vunicodestring[1]<>cwidecharin then + raise jlexception.create('const stringwidechar out'); + vsingle:=csinglein; + testformalconst(vsingle,fsingle); + if vsingle<>csinglein then + raise jlexception.create('const single out'); + vdouble:=cdoublein; + testformalconst(vdouble,fdouble); + if vdouble<>cdoublein then + raise jlexception.create('const double out'); + vsetint:=csetintin; + testformalconst(vsetint,fsetint); + if vsetint<>csetintin then + raise jlexception.create('const setint out'); + vsetenum:=csetenumin; + testformalconst(vsetenum,fsetenum); + if vsetenum<>csetenumin then + raise jlexception.create('const setenum out'); + vrec:=crecin; + testformalconst(vrec,frec); + if crecin.a<>vrec.a then + raise jlexception.create('const rec.a out'); + if crecin.b[3]<>vrec.b[3] then + raise jlexception.create('const rec.b[3] out'); + if crecin.b[4]<>vrec.b[4] then + raise jlexception.create('const rec.b[4] out'); + vshortstring:=cshortstringin; + testformalconst(vshortstring,fshortstring); + if vshortstring<>cshortstringin then + raise jlexception.create('const shortstring out'); + vunicodestring:=cunicodestringin; + testformalconst(vunicodestring,funicodestring); + if vunicodestring<>cunicodestringin then + raise jlexception.create('const unicodestring out'); + varrbyte:=carrbytein; + testformalconst(varrbyte,farrbyte); + for i:=low(carrbytein) to high(carrbytein) do + if carrbytein[i]<>varrbyte[i] then + raise jlexception.create('const arrbyte out'); + varrset:=carrsetin; + testformalconst(varrset,farrset); + for i:=low(carrsetin) to high(carrsetin) do + if varrset[i]<>carrsetin[i] then + raise jlexception.create('const arrset out'); + end; + + +procedure main(args: array of string); +begin + test; + testformalvars; + testformalouts; + testformalconsts; +end; + +end. diff --git a/tests/test/jvm/tint.pp b/tests/test/jvm/tint.pp new file mode 100644 index 0000000000..6963493274 --- /dev/null +++ b/tests/test/jvm/tint.pp @@ -0,0 +1,236 @@ +{ this tests the int routine } +{ Contrary to TP, int can be used in the constant section, + just like in Delphi } +program tint; + +{$modeswitch exceptions} + +uses + jdk15; + +{$ifdef VER1_0} + {$define SKIP_CURRENCY_TEST} +{$endif } + +{$macro on} +{$define writeln:=JLSystem.fout.println} +{$define write:=JLSystem.fout.print} + +const + INT_RESULT_ONE = 1234; + INT_VALUE_ONE = 1234.5678; + INT_RESULT_CONST_ONE = Int(INT_VALUE_ONE); + INT_RESULT_TWO = -1234; + INT_VALUE_TWO = -1234.5678; + INT_RESULT_CONST_TWO = Int(INT_VALUE_TWO); + + + procedure fail; + begin + WriteLn('Failed!'); +// halt(1); + raise JLException.create('boo!'); + end; + +procedure test_int_real; +var + r: real; + _success : boolean; +Begin + Write('Int() real testing...'); + _success := true; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_ONE then + _success:=false; + if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then + _success:=false; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_CONST_ONE then + _success := false; + r:=INT_VALUE_ONE; + r:=Int(r); + if r<>INT_RESULT_ONE then + _success:=false; + r:=Int(INT_VALUE_ONE); + if r<>INT_RESULT_ONE then + _success:=false; + + + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_TWO then + _success:=false; + if Int(INT_VALUE_TWO)<>INT_RESULT_TWO then + _success:=false; + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_CONST_TWO then + _success := false; + r:=INT_VALUE_TWO; + r:=Int(r); + if r<>INT_RESULT_TWO then + _success:=false; + r:=Int(INT_VALUE_TWO); + if r<>INT_RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + +procedure test_int_single; +var + r: single; + _success : boolean; +Begin + Write('Int() single testing...'); + _success := true; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_ONE then + _success:=false; + if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then + _success:=false; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_CONST_ONE then + _success := false; + r:=INT_VALUE_ONE; + r:=Int(r); + if r<>INT_RESULT_ONE then + _success:=false; + r:=Int(INT_VALUE_ONE); + if r<>INT_RESULT_ONE then + _success:=false; + + + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_TWO then + _success:=false; + if Int(INT_VALUE_TWO)<>INT_RESULT_TWO then + _success:=false; + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_CONST_TWO then + _success := false; + r:=INT_VALUE_TWO; + r:=Int(r); + if r<>INT_RESULT_TWO then + _success:=false; + r:=Int(INT_VALUE_TWO); + if r<>INT_RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + +procedure test_int_double; +var + r: double; + _success : boolean; +Begin + Write('Int() double testing...'); + _success := true; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_ONE then + _success:=false; + if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then + _success:=false; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_CONST_ONE then + _success := false; + r:=INT_VALUE_ONE; + r:=Int(r); + if r<>INT_RESULT_ONE then + _success:=false; + r:=Int(INT_VALUE_ONE); + if r<>INT_RESULT_ONE then + _success:=false; + + + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_TWO then + _success:=false; + if Int(INT_VALUE_TWO)<>INT_RESULT_TWO then + _success:=false; + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_CONST_TWO then + _success := false; + r:=INT_VALUE_TWO; + r:=Int(r); + if r<>INT_RESULT_TWO then + _success:=false; + r:=Int(INT_VALUE_TWO); + if r<>INT_RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + +{$ifndef SKIP_CURRENCY_TEST} +procedure test_int_currency; +var + r: currency; + _success : boolean; +Begin + Write('Int() currency testing...'); + _success := true; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_ONE then + _success:=false; + + if not _success then + fail; + + if Int(INT_VALUE_ONE)<>INT_RESULT_ONE then + _success:=false; + r:=INT_VALUE_ONE; + if Int(r)<>INT_RESULT_CONST_ONE then + _success := false; + r:=INT_VALUE_ONE; + r:=Int(r); + if r<>INT_RESULT_ONE then + _success:=false; + r:=Int(INT_VALUE_ONE); + if r<>INT_RESULT_ONE then + _success:=false; + + if not _success then + fail; + + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_TWO then + _success:=false; + if Int(INT_VALUE_TWO)<>INT_RESULT_TWO then + _success:=false; + r:=INT_VALUE_TWO; + if Int(r)<>INT_RESULT_CONST_TWO then + _success := false; + r:=INT_VALUE_TWO; + r:=Int(r); + if r<>INT_RESULT_TWO then + _success:=false; + r:=Int(INT_VALUE_TWO); + if r<>INT_RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; +{$endif SKIP_CURRENCY_TEST} + +Begin + test_int_real; + test_int_double; + test_int_single; +{$ifdef SKIP_CURRENCY_TEST} + Writeln('Skipping currency test because its not supported by theis compiler'); +{$else SKIP_CURRENCY_TEST} + test_int_currency; +{$endif SKIP_CURRENCY_TEST} +end. diff --git a/tests/test/jvm/tintstr.pp b/tests/test/jvm/tintstr.pp new file mode 100644 index 0000000000..d48674b98b --- /dev/null +++ b/tests/test/jvm/tintstr.pp @@ -0,0 +1,139 @@ +program tintstr; + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} +{$endif} + +var + l: longint; + c: cardinal; + i: int64; + q: qword; + +type + tr1 = packed record + s: string[1]; + b1,b2,b3,b4: byte; + end; +procedure ts1(const res1, res2, res3, res4: string); +var + r: tr1; +begin + with r do + begin + b1:=0; + b2:=0; + b3:=0; + b4:=0; + str(l,s); + if (res1<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(1); + + str(c,s); + if (res2<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(2); + + str(i,s); + if (res3<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(3); + + str(q,s); + if (res4<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(4); + end; +end; + + +type + tr2 = packed record + s: string[3]; + b1,b2,b3,b4: byte; + end; + +procedure ts3(const res1, res2, res3, res4: string); +var + r: tr2; +begin + with r do + begin + b1:=0; + b2:=0; + b3:=0; + b4:=0; + str(l,s); + if (res1<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(1); + + str(c,s); + if (res2<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(2); + + str(i,s); + if (res3<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(3); + + str(q,s); + if (res4<>s) or + (b1<>0) or + (b2<>0) or + (b3<>0) or + (b4<>0) then + halt(4); + end; +end; + +var + a: ansistring; + u: unicodestring; + xl: longint; +begin + l:=high(longint); + c:=high(cardinal); + i:=high(int64); + q:=high(qword); + ts1('2','4','9','1'); + ts3('214','429','922','184'); + l:=low(longint)+1; + c:=high(cardinal)-1; + i:=low(int64)+1; + q:=high(qword)-1; + ts1('-','4','-','1'); + ts3('-21','429','-92','184'); +(* + str(1,a); + str(2,u); +*) +end. diff --git a/tests/test/jvm/tnestproc.pp b/tests/test/jvm/tnestproc.pp new file mode 100644 index 0000000000..d6f8046da6 --- /dev/null +++ b/tests/test/jvm/tnestproc.pp @@ -0,0 +1,40 @@ +program tnestproc; + +{$mode delphi} + +uses + jdk15; + +procedure outer(var para: byte); + const xxx: longint = 5; + var + a: longint; + + procedure inner; + begin + if a<>1 then + raise JLException.Create('a1'); + if para<>2 then + raise JLException.Create('para1'); + a:=2; + para:=3; + end; + + begin + a:=1; + inner; + if a<>2 then + raise JLException.Create('a2'); + if para<>3 then + raise JLException.Create('para2'); + end; + +var + x: record end; + y: byte; +begin + y:=2; + outer(y); + if y<>3 then + raise JLException.Create('para3'); +end. diff --git a/tests/test/jvm/tprop.pp b/tests/test/jvm/tprop.pp new file mode 100644 index 0000000000..de62e9c9ae --- /dev/null +++ b/tests/test/jvm/tprop.pp @@ -0,0 +1,43 @@ +program tprop; + +{$mode delphi} + +uses + jdk15; + +type + tc = class + strict private + fvalue: longint; + function getit: longint; + procedure setit(l: longint); + public + property value: longint read getit write setit; + constructor create(l: longint); + end; + + constructor tc.create(l: longint); + begin + fvalue:=l; + end; + + + function tc.getit: longint; + begin + result:=fvalue; + end; + + + procedure tc.setit(l: longint); + begin + fvalue:=l; + end; + +var + c: tc; +begin + c:=tc.create(5); + jlsystem.fout.println(c.value); + c.value:=6; + jlsystem.fout.println(c.value); +end. diff --git a/tests/test/jvm/tprop2.pp b/tests/test/jvm/tprop2.pp new file mode 100644 index 0000000000..a4516701ff --- /dev/null +++ b/tests/test/jvm/tprop2.pp @@ -0,0 +1,46 @@ +program tprop2; + +{$mode delphi} + +uses + jdk15; + +type + tpropclass1 = class + strict private + fx : integer; + public + procedure Reset; virtual; + + end; + + tpropclass2 = class(tpropclass1) + strict private + fx : integer; + public + procedure Reset; override; + property x : integer read fx write fx; + end; + +procedure tpropclass1.Reset; +begin + fx := 777; +end; + +procedure tpropclass2.Reset; +begin + fx := 888; +end; + +var + t : tpropclass2; +begin + t := tpropclass2.create; + t.reset; + if t.x<>888 then + raise jlexception.create('error 1'); + t.x:=555; + if t.x<>555 then + raise jlexception.create('error 1'); +end. + diff --git a/tests/test/jvm/tpvar.pp b/tests/test/jvm/tpvar.pp new file mode 100644 index 0000000000..2d871744e6 --- /dev/null +++ b/tests/test/jvm/tpvar.pp @@ -0,0 +1,103 @@ +program tpvar; + +{$mode objfpc} + +uses + jdk15; + +type + tmprec = record + b: byte; + end; + + tmethodclass = class + l: longint; + procedure test(x: longint; w: word; r: tmprec; var ro: tmprec); + class procedure classproc(b: longint); + class procedure callclassproc; + end; + + tmethodclass2 = class(tmethodclass) + class procedure classproc(b: longint); + end; + + tmypvar = procedure(x: longint; w: word; r: tmprec; var ro: tmprec) of object; + + + procedure tmethodclass.test(x: longint; w: word; r: tmprec; var ro: tmprec); + begin + jlsystem.fout.print('l: '); + jlsystem.fout.println(l); + jlsystem.fout.print('x: '); + jlsystem.fout.println(x); + jlsystem.fout.print('w: '); + jlsystem.fout.println(w); + jlsystem.fout.print('r.b: '); + jlsystem.fout.println(r.b); + jlsystem.fout.print('ro.b: '); + jlsystem.fout.println(ro.b); + if l<>6 then + raise jlexception.create('l wrong on input'); + if x<>1 then + raise jlexception.create('x wrong on input'); + if w<>$ffff then + raise jlexception.create('w wrong on input'); + if r.b<>21 then + raise jlexception.create('r.b wrong on input'); + if ro.b<>42 then + raise jlexception.create('ro.b wrong on input'); + r.b:=123; + ro.b:=123; + end; + + + class procedure tmethodclass.classproc(b: longint); + begin + jlsystem.fout.println('tmethodclass.classproc'); + end; + + class procedure tmethodclass.callclassproc; + type + pv = procedure(l: longint) of object; + var + v: pv; + begin + v:=@classproc; + v(3); + end; + + + + class procedure tmethodclass2.classproc(b: longint); + begin + jlsystem.fout.println('tmethodclass2.classproc'); + end; + +type + tcc = class of tmethodclass; + +var + mypvar: tmypvar; + c: tmethodclass; + r, ro: tmprec; + cc: tcc; +begin + r.b:=21; + ro.b:=42; + c:=tmethodclass2.create; + c.l:=6; + mypvar:=@c.test; + mypvar(1,$ffff,r,ro); + if r.b<>21 then + raise jlexception.create('r changed'); + if ro.b<>123 then + raise jlexception.create('ro not changed'); + c.free; + + tmethodclass.callclassproc; + tmethodclass2.callclassproc; + cc:=tmethodclass; + cc.callclassproc; + cc:=tmethodclass2; + cc.callclassproc; +end. diff --git a/tests/test/jvm/tpvardelphi.pp b/tests/test/jvm/tpvardelphi.pp new file mode 100644 index 0000000000..27fe72069a --- /dev/null +++ b/tests/test/jvm/tpvardelphi.pp @@ -0,0 +1,97 @@ +program tpvardelphi; + +{$mode delphi} + +uses + jdk15; + +type + tmprec = record + b: byte; + end; + + tmethodclass = class + l: longint; + procedure test(x: longint; w: word; r: tmprec; var ro: tmprec); + procedure shorttest(b: byte); + procedure shorttest2(b: byte); + end; + + tmypvar = procedure(x: longint; w: word; r: tmprec; var ro: tmprec) of object; + tmyshortpvar = procedure(b: byte) of object; + + + procedure tmethodclass.test(x: longint; w: word; r: tmprec; var ro: tmprec); + begin + jlsystem.fout.print('l: '); + jlsystem.fout.println(l); + jlsystem.fout.print('x: '); + jlsystem.fout.println(x); + jlsystem.fout.print('w: '); + jlsystem.fout.println(w); + jlsystem.fout.print('r.b: '); + jlsystem.fout.println(r.b); + jlsystem.fout.print('ro.b: '); + jlsystem.fout.println(ro.b); + if l<>6 then + raise jlexception.create('l wrong on input'); + if x<>1 then + raise jlexception.create('x wrong on input'); + if w<>$ffff then + raise jlexception.create('w wrong on input'); + if r.b<>21 then + raise jlexception.create('r.b wrong on input'); + if ro.b<>42 then + raise jlexception.create('ro.b wrong on input'); + r.b:=123; + ro.b:=123; + end; + + procedure tmethodclass.shorttest(b: byte); + begin + if b<>129 then + raise jlexception.create('shorttest b wrong'); + if l<>7 then + raise jlexception.create('shorttest l wrong'); + end; + + procedure tmethodclass.shorttest2(b: byte); + begin + if b<>130 then + raise jlexception.create('shorttest2 b wrong'); + if l<>6 then + raise jlexception.create('shorttest l wrong'); + end; + +var + mypvar, mypvar2: tmypvar; + c,c2: tmethodclass; + r, ro: tmprec; + meth: tmethod; + shortpvar1,shortpvar2: tmyshortpvar; +begin + r.b:=21; + ro.b:=42; + c:=tmethodclass.create; + c.l:=6; + mypvar:=c.test; + meth:=tmethod(mypvar); + mypvar:=tmypvar(meth); + mypvar(1,$ffff,r,ro); + if r.b<>21 then + raise jlexception.create('r changed'); + if ro.b<>123 then + raise jlexception.create('ro not changed'); + + c2:=tmethodclass.create; + c2.l:=7; + + shortpvar1:=c.shorttest; + shortpvar2:=c2.shorttest2; + { should only copy the procedure pointer, not the instance -> + instance.l=6, expected parameter = 130 } + @shortpvar1:=@shortpvar2; + shortpvar1(130); + + c.free; +end. diff --git a/tests/test/jvm/tpvarglobal.pp b/tests/test/jvm/tpvarglobal.pp new file mode 100644 index 0000000000..458ab61f5a --- /dev/null +++ b/tests/test/jvm/tpvarglobal.pp @@ -0,0 +1,53 @@ +program tpvarglobal; + +{$mode objfpc} + +uses + jdk15; + +type + tmprec = record + b: byte; + end; + + tmypvar = function(x: longint; w: word; r: tmprec; var ro: tmprec): shortstring; + + function test(x: longint; w: word; r: tmprec; var ro: tmprec): shortstring; + begin + jlsystem.fout.print('x: '); + jlsystem.fout.println(x); + jlsystem.fout.print('w: '); + jlsystem.fout.println(w); + jlsystem.fout.print('r.b: '); + jlsystem.fout.println(r.b); + jlsystem.fout.print('ro.b: '); + jlsystem.fout.println(ro.b); + if x<>1 then + raise jlexception.create('x wrong on input'); + if w<>$ffff then + raise jlexception.create('w wrong on input'); + if r.b<>21 then + raise jlexception.create('r.b wrong on input'); + if ro.b<>42 then + raise jlexception.create('ro.b wrong on input'); + r.b:=123; + ro.b:=123; + result:='abc'; + end; + +var + mypvar: tmypvar; + r, ro: tmprec; + res: shortstring; +begin + r.b:=21; + ro.b:=42; + mypvar:=@test; + res:=mypvar(1,$ffff,r,ro); + if r.b<>21 then + raise jlexception.create('r changed'); + if ro.b<>123 then + raise jlexception.create('ro not changed'); + if res<>'abc' then + raise jlexception.create('result wrong'); +end. diff --git a/tests/test/jvm/tpvarglobaldelphi.pp b/tests/test/jvm/tpvarglobaldelphi.pp new file mode 100644 index 0000000000..c757dbff66 --- /dev/null +++ b/tests/test/jvm/tpvarglobaldelphi.pp @@ -0,0 +1,53 @@ +program tpvarglobaldelphi; + +{$mode delphi} + +uses + jdk15; + +type + tmprec = record + b: byte; + end; + + tmypvar = function(x: longint; w: word; r: tmprec; var ro: tmprec): shortstring; + + function test(x: longint; w: word; r: tmprec; var ro: tmprec): shortstring; + begin + jlsystem.fout.print('x: '); + jlsystem.fout.println(x); + jlsystem.fout.print('w: '); + jlsystem.fout.println(w); + jlsystem.fout.print('r.b: '); + jlsystem.fout.println(r.b); + jlsystem.fout.print('ro.b: '); + jlsystem.fout.println(ro.b); + if x<>1 then + raise jlexception.create('x wrong on input'); + if w<>$ffff then + raise jlexception.create('w wrong on input'); + if r.b<>21 then + raise jlexception.create('r.b wrong on input'); + if ro.b<>42 then + raise jlexception.create('ro.b wrong on input'); + r.b:=123; + ro.b:=123; + result:='abc'; + end; + +var + mypvar: tmypvar; + r, ro: tmprec; + res: shortstring; +begin + r.b:=21; + ro.b:=42; + mypvar:=test; + res:=mypvar(1,$ffff,r,ro); + if r.b<>21 then + raise jlexception.create('r changed'); + if ro.b<>123 then + raise jlexception.create('ro not changed'); + if res<>'abc' then + raise jlexception.create('result wrong'); +end. diff --git a/tests/test/jvm/trange1.pp b/tests/test/jvm/trange1.pp new file mode 100644 index 0000000000..be3f2e2194 --- /dev/null +++ b/tests/test/jvm/trange1.pp @@ -0,0 +1,255 @@ +program trange1; + +{ %VERSION=1.1 } + +{$ifdef fpc} + {$mode objfpc} +{$endif} + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} + +type + qprinttype = int64; + +{$else} +uses + SysUtils; + +type + qprinttype = qword; +{$endif} + + +{$ifndef fpc} +type + qword=int64; + dword=cardinal; +{$endif} + +var + error: boolean; + +{$r+} +function testlongint_int64(i: int64; shouldfail: boolean): boolean; +var + l: longint; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testlongint_qword(i: qword; shouldfail: boolean): boolean; +var + l: longint; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testdword_int64(i: int64; shouldfail: boolean): boolean; +var + l: dword; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +function testdword_qword(i: qword; shouldfail: boolean): boolean; +var + l: dword; + failed: boolean; +begin + failed := false; + try + l := i; + except + failed := true; + end; + result := failed = shouldfail; + error := error or not result; +end; + +{$r-} + +var + i: int64; + q: qword; +begin + error := false; +{ *********************** int64 to longint ********************* } + writeln('int64 to longint'); + i := $ffffffffffffffff; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test1 failed'); + i := i and $ffffffff00000000; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test2 failed'); + inc(i); + writeln(i); + if not testlongint_int64(i,true) then + writeln('test3 failed'); + i := $ffffffff80000000; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test4 failed'); + i := $80000000; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test5 failed'); + dec(i); + writeln(i); + if not testlongint_int64(i,false) then + writeln('test6 failed'); + i := $ffffffff; + writeln(i); + if not testlongint_int64(i,true) then + writeln('test7 failed'); + i := 0; + writeln(i); + if not testlongint_int64(i,false) then + writeln('test8 failed'); + +{ *********************** qword to longint ********************* } + writeln; + writeln('qword to longint'); + q := qword($ffffffffffffffff); + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test1 failed'); + q := q and $ffffffff00000000; + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test2 failed'); + inc(q); + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test3 failed'); + q := $ffffffff80000000; + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test4 failed'); + q := $80000000; + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test5 failed'); + dec(q); + writeln(qprinttype(q)); + if not testlongint_qword(q,false) then + writeln('test6 failed'); + q := $ffffffff; + writeln(qprinttype(q)); + if not testlongint_qword(q,true) then + writeln('test7 failed'); + q := 0; + writeln(qprinttype(q)); + if not testlongint_qword(q,false) then + writeln('test8 failed'); + +{ *********************** int64 to dword ********************* } + writeln; + writeln('int64 to dword'); + i := $ffffffffffffffff; + writeln(i); + if not testdword_int64(i,true) then + writeln('test1 failed'); + i := i and $ffffffff00000000; + writeln(i); + if not testdword_int64(i,true) then + writeln('test2 failed'); + inc(i); + writeln(i); + if not testdword_int64(i,true) then + writeln('test3 failed'); + i := $ffffffff80000000; + writeln(i); + if not testdword_int64(i,true) then + writeln('test4 failed'); + i := $80000000; + writeln(i); + if not testdword_int64(i,false) then + writeln('test5 failed'); + dec(i); + writeln(i); + if not testdword_int64(i,false) then + writeln('test6 failed'); + i := $ffffffff; + writeln(i); + if not testdword_int64(i,false) then + writeln('test7 failed'); + i := 0; + writeln(i); + if not testdword_int64(i,false) then + writeln('test8 failed'); + +{ *********************** qword to dword ********************* } + writeln; + writeln('qword to dword'); + q := $ffffffffffffffff; + writeln(qprinttype(q)); + if not testdword_qword(q,true) then + writeln('test1 failed'); + q := q and $ffffffff00000000; + writeln(qprinttype(q)); + if not testdword_qword(q,true) then + writeln('test2 failed'); + inc(q); + writeln(qprinttype(q)); + if not testdword_qword(q,true) then + writeln('test3 failed'); + q := $ffffffff80000000; + writeln(qprinttype(q)); + if not testdword_qword(q,true) then + writeln('test4 failed'); + q := $80000000; + writeln(qprinttype(q)); + if not testdword_qword(q,false) then + writeln('test5 failed'); + dec(q); + writeln(qprinttype(q)); + if not testdword_qword(q,false) then + writeln('test6 failed'); + q := $ffffffff; + writeln(qprinttype(q)); + if not testdword_qword(q,false) then + writeln('test7 failed'); + q := 0; + writeln(qprinttype(q)); + if not testdword_qword(q,false) then + writeln('test8 failed'); + + if error then + begin + writeln; + writeln('still range check problems!'); + halt(1); + end; +end. diff --git a/tests/test/jvm/trange2.pp b/tests/test/jvm/trange2.pp new file mode 100644 index 0000000000..9ad8282f4c --- /dev/null +++ b/tests/test/jvm/trange2.pp @@ -0,0 +1,43 @@ +program trange2; + +{$mode objfpc} +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} +{$else} +uses + SysUtils; +{$endif} + +{$r+} + +var + l: longint; + c: cardinal; + n: longint; +begin + n := 0; + l := -1; + try + c := l; + except + writeln('caught 1!'); + inc(n); + end; + c := cardinal($ffffffff); + try + l := c; + except + writeln('caught 2!'); + inc(n); + end; + if n <> 2 then + begin + writeln('Still problems with range checking between longint/cardinal'); + halt(1); + end; +end. diff --git a/tests/test/jvm/trange3.pp b/tests/test/jvm/trange3.pp new file mode 100644 index 0000000000..5f6ba15e78 --- /dev/null +++ b/tests/test/jvm/trange3.pp @@ -0,0 +1,149 @@ +program trange3; + +{$mode objfpc} + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} + +{$else} +uses + SysUtils; +{$endif} + + +{$r+} + +var + a1: array[-5..6] of byte; + a2: array[-12..-1] of byte; + a3: array[0..6] of byte; + a4: array[1..12] of byte; + + c: cardinal; + l: longint; + b: byte; + finalerror: boolean; + +function check_longint(l: longint; res1, res2, res3, res4: boolean): boolean; +var + caught, + error: boolean; +begin + result := false; + + caught := false; + try + b := a1[l]; + except + caught := true; + end; + error := caught <> res1; + if error then writeln('long 1 failed for '+unicodestring(JLInteger.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a2[l]; + except + caught := true; + end; + error := caught <> res2; + if error then writeln('long 2 failed for '+unicodestring(JLInteger.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a3[l]; + except + caught := true; + end; + error := caught <> res3; + if error then writeln('long 3 failed for '+unicodestring(JLInteger.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a4[l]; + except + caught := true; + end; + error := caught <> res4; + if error then writeln('long 4 failed for '+unicodestring(JLInteger.valueOf(l).toString)); + result := result or error; + writeln; +end; + +function check_cardinal(l: cardinal; res1, res2, res3, res4: boolean): boolean; +var + caught, + error: boolean; +begin + result := false; + + caught := false; + try + b := a1[l]; + except + caught := true; + end; + error := caught <> res1; + if error then writeln('card 1 failed for '+unicodestring(JLLong.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a2[l]; + except + caught := true; + end; + error := caught <> res2; + if error then writeln('card 2 failed for '+unicodestring(JLLong.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a3[l]; + except + caught := true; + end; + error := caught <> res3; + if error then writeln('card 3 failed for '+unicodestring(JLLong.valueOf(l).toString)); + result := result or error; + + caught := false; + try + b := a4[l]; + except + caught := true; + end; + error := caught <> res4; + if error then writeln('card 4 failed for '+unicodestring(JLLong.valueOf(l).toString)); + result := result or error; + writeln; +end; + + +begin + finalerror := + check_longint(-1,false,false,true,true); + finalerror := + check_longint(-6,true,false,true,true) or finalerror; + finalerror := + check_longint(0,false,true,false,true) or finalerror; + finalerror := + check_cardinal(0,false,true,false,true); + finalerror := + check_cardinal(cardinal($ffffffff),true,true,true,true) or finalerror; + finalerror := + check_cardinal(5,false,true,false,false) or finalerror; + if finalerror then + begin + writeln('Still errors in range checking for array indexes'); + halt(1); + end; +end. diff --git a/tests/test/jvm/tset1.pp b/tests/test/jvm/tset1.pp new file mode 100644 index 0000000000..278912ccf8 --- /dev/null +++ b/tests/test/jvm/tset1.pp @@ -0,0 +1,183 @@ +{ + + Program to test set functions +} + +{$define FPC_HAS_SET_INEQUALITIES} + +program tset1; + +{$ifdef cpujvm} +uses + jdk15; + +{$macro on} +{$define writeln:=jlsystem.fout.println} +{$define write:=jlsystem.fout.println} +{$endif} + + +Procedure InitMSTimer; +begin +end; + + +{Get MS Timer} +Function MSTimer:longint; +begin + MSTimer:=0; +end; + + +const + Lval=2000; +VAR Box1, Box2: ARRAY [0..255] OF BYTE; + OneWOTwo, TwoWOOne, + UnionSet, InterSet, + Set1, Set2, Set3: SET OF BYTE; + K, MaxNr, L, + N, Low, Hi: INTEGER; + Start: LONGINT; + +begin + WriteLn ('Set operators functional and speed test'); + WriteLn; + + RandSeed := 17; + + for L := 0 TO 255 DO begin + Box1 [L] := L; + end; + MaxNr := 255; + for L := 0 TO 255 DO begin + K := Random (MaxNr+1); + Box2 [L] := Box1 [K]; + Box1 [K] := Box1 [MaxNr]; + Dec (MaxNr); + end; + + Start :=MSTimer; + + Set1 := []; + Set2 := []; + for L := 0 TO 255 DO begin + Set1 := Set1 + [Box2 [L]]; + if NOT (Box2 [L] IN Set1) then begin + WriteLn ('error in AddElem or InSet functions'); + Halt; + end; + Set2 := Set2 + [Box2 [L]] + []; + end; + +{$ifdef FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) OR (NOT (Set1 <= Set2)) OR (NOT (Set1 >= Set2)) then begin +{$else FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) then begin +{$endif FPC_HAS_SET_INEQUALITIES } + WriteLn ('error in relational operators 1'); + Halt; + end; + + for L := 0 TO 255 DO begin + Set1 := Set1 - [Box2 [L]]; + if Box2 [L] IN Set1 then begin + WriteLn ('error in set difference 1'); + Halt; + end; + end; + + if Set1 <> [] then begin + WriteLn ('error in set difference 2'); + Halt; + end; + + for L := 1 TO LVal DO begin + REPEAT + Low := Random (256); + Hi := Random (256); + UNTIL Low <= Hi; + + Set1 := []; + Set1 := Set1 + [Low..Hi]; + for K := 0 TO 255 DO begin + if (K IN Set1) AND ((K < Low) OR (K > Hi)) then begin + WriteLn ('wrong set inclusion in add range'); + Halt; + end; + if (NOT (K IN Set1)) AND ((K >= Low) AND (K <= Hi)) then begin + WriteLn ('wrong set exclusion in add range'); + Halt; + end; + end; + end; + + for L := 1 TO LVal DO begin + Set1 := []; + Set2 := []; + + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Low + Random (256-Low); + Set2:= Set1 + [Low..Hi]; +{$ifdef FPC_HAS_SET_INEQUALITIES } + if (Set1 >= Set2) AND (Set1 <> Set2) then begin +{$else FPC_HAS_SET_INEQUALITIES } + if (Set1 <> Set2) then begin +{$endif FPC_HAS_SET_INEQUALITIES } + WriteLn ('error in relational operators 2'); + Halt; + end; +{$ifdef FPC_HAS_SET_INEQUALITIES } + if NOT (Set1 <= Set2) then begin + WriteLn ('error in relational operators 3'); + Halt; + end; +{$endif FPC_HAS_SET_INEQUALITIES } + Set1 := Set2; + + end; + end; + + for L := 1 TO LVal DO begin + Set1 := []; + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Low + Random (256-Low); + Set1:= Set1 + [Low..Hi]; + end; + Set2 := []; + for K := 1 TO 10 DO begin + Low := Random (256); + Hi := Low + Random (256-Low); + Set2:= Set2 + [Low..Hi]; + end; + + OneWOTwo := Set1 - Set2; + TwoWOOne := Set2 - Set1; + InterSet := Set1 * Set2; + UnionSet := Set1 + Set2; + + if InterSet <> (Set2 * Set1) then begin + WriteLn ('error in set difference'); + Halt; + end; + + if (InterSet + OneWOTwo) <> Set1 then begin + WriteLn ('error in set difference or intersection'); + Halt; + end; + + if (InterSet + TwoWOOne) <> Set2 then begin + WriteLn ('error in set difference or intersection'); + Halt; + end; + + if (OneWOTwo + TwoWOOne + InterSet) <> UnionSet then begin + WriteLn ('error in set union, intersection or difference'); + Halt; + end; + + end; + Start:=MSTimer-Start; +// WriteLn('Set test completes in ',Start,' ms'); +end. diff --git a/tests/test/jvm/tset3.pp b/tests/test/jvm/tset3.pp new file mode 100644 index 0000000000..36723428a6 --- /dev/null +++ b/tests/test/jvm/tset3.pp @@ -0,0 +1,98 @@ +program tset3; + +{$modeswitch exceptions} + +uses + jdk15; + +{$macro on} +{$define writeln:=JLSystem.fout.println} +{$define write:=JLSystem.fout.print} + +{$packset 1} +type + tmini = 0..7; + tminiset = set of tmini; + + +procedure do_error(w : word); + begin + write('Error: '); + writeln(w); + raise jlexception.create('error!'); + end; + +{$ifdef proc} +procedure testit; +{$endif} +var + s1,s2,s3 : tminiset; + b : byte; + m : tmini; +begin + s1:=[]; + if s1<>[] then + do_error(1); + + s1:=[1]; + if s1<>[1] then + do_error(2); + + s2:=[2,3]; + if s2<>[2,3] then + do_error(3); + + b:=6; + s3:=[b,7]; + if s3<>[6,7] then + do_error(4); + + s1:=s1+s2; + if s1<>[1..3] then + do_error(5); + + s2:=s1; + + if not(s1=s2) then + do_error(6); + + s3:=[4]; + + include(s1,4); + if s1<>[1..4] then + do_error(7); + + s2:=s1; + + exclude(s1,4); + if s1<>[1..3] then + do_error(8); + + s2:=s2-s3; + if s1<>s2 then + do_error(9); + + b:=4; + include(s1,b); + if s1<>[1..4] then + do_error(10); + + s2:=s2+[b]; + if s1<>s2 then + do_error(11); + + s2:=s1; + m:=3; + s1:=s1-[m]; + exclude(s2,m); + if s1<>s2 then + do_error(12); + + writeln('ok'); +{$ifdef proc} +end; + +begin + testit; +{$endif} +end. diff --git a/tests/test/jvm/ttrig.pp b/tests/test/jvm/ttrig.pp new file mode 100644 index 0000000000..ea54b94031 --- /dev/null +++ b/tests/test/jvm/ttrig.pp @@ -0,0 +1,50 @@ +program ttrig; + +{$modeswitch exceptions} + +uses + jdk15; + +{$macro on} +{$define writeln:=JLSystem.fout.println} + +procedure do_error(i : longint); + begin +// writeln('Error near ',i); + raise JLException.create('Error near '+UnicodeString(JLInteger.valueOf(i).toString)); + end; + +var + s0,s1,s2 : single; + + +begin + writeln('--- Testing single functions ---'); + + // 0.0 + s0:=0.0; + + s1:=sin(s0); + if s1<>0.0 then + do_error(1); + + s1:=cos(s0); + if s1<>1.0 then + do_error(2); + + s1:=arctan(s0); + if s1<>0.0 then + do_error(3); + + // pi/2 + s2:=pi/2; + + s1:=sin(s2); + if s1<>1.0 then + do_error(100); + + s1:=cos(s2); + { with single precision, the result is -4.371138829E-08 } + if abs(s1-0.0)>4.371138829E-08 then + do_error(101); +end. diff --git a/tests/test/jvm/ttrunc.pp b/tests/test/jvm/ttrunc.pp new file mode 100644 index 0000000000..889dd610df --- /dev/null +++ b/tests/test/jvm/ttrunc.pp @@ -0,0 +1,241 @@ +{ this tests the trunc routine } +program ttrunc; + +{$modeswitch exceptions} + +uses + jdk15; + +{$macro on} + +{$define write:=jlsystem.fout.print} +{$define writeln:=jlsystem.fout.println} + +{$ifdef VER1_0} + {$define SKIP_CURRENCY_TEST} +{$endif } + +{$ifndef MACOS} +{$APPTYPE CONSOLE} +{$else} +{$APPTYPE TOOL} +{$endif} + +const + RESULT_ONE = 1234; + VALUE_ONE = 1234.5678; + RESULT_CONST_ONE = trunc(VALUE_ONE); + RESULT_TWO = -1234; + VALUE_TWO = -1234.5678; + RESULT_CONST_TWO = trunc(VALUE_TWO); + + + procedure fail; + begin + WriteLn('Failed!'); + raise jlexception.create('boo'); + end; + +procedure test_trunc_real; +var + r: real; + _success : boolean; + l: longint; +Begin + Write('Trunc() real testing...'); + _success := true; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_ONE then + _success:=false; + if Trunc(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=Trunc(r); + if l<>RESULT_ONE then + _success:=false; + l:=Trunc(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if Trunc(r)<>RESULT_TWO then + _success:=false; + if Trunc(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if Trunc(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=Trunc(r); + if l<>RESULT_TWO then + _success:=false; + l:=Trunc(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + +procedure test_trunc_single; +var + r: single; + _success : boolean; + l: longint; +Begin + Write('Trunc() single testing...'); + _success := true; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_ONE then + _success:=false; + if Trunc(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=Trunc(r); + if l<>RESULT_ONE then + _success:=false; + l:=Trunc(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if Trunc(r)<>RESULT_TWO then + _success:=false; + if Trunc(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if Trunc(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=Trunc(r); + if l<>RESULT_TWO then + _success:=false; + l:=Trunc(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + + +procedure test_trunc_double; +var + r: double; + _success : boolean; + l: longint; +Begin + Write('Trunc() double testing...'); + _success := true; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_ONE then + _success:=false; + if Trunc(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=Trunc(r); + if l<>RESULT_ONE then + _success:=false; + l:=Trunc(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if Trunc(r)<>RESULT_TWO then + _success:=false; + if Trunc(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if Trunc(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=Trunc(r); + if l<>RESULT_TWO then + _success:=false; + l:=Trunc(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; + + +{$ifndef SKIP_CURRENCY_TEST} +procedure test_trunc_currency; +var + r: currency; + _success : boolean; + l: longint; +Begin + Write('Trunc() currency testing...'); + _success := true; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_ONE then + _success:=false; + if Trunc(VALUE_ONE)<>RESULT_ONE then + _success:=false; + r:=VALUE_ONE; + if Trunc(r)<>RESULT_CONST_ONE then + _success := false; + r:=VALUE_ONE; + l:=Trunc(r); + if l<>RESULT_ONE then + _success:=false; + l:=Trunc(VALUE_ONE); + if l<>RESULT_ONE then + _success:=false; + + + r:=VALUE_TWO; + if Trunc(r)<>RESULT_TWO then + _success:=false; + if Trunc(VALUE_TWO)<>RESULT_TWO then + _success:=false; + r:=VALUE_TWO; + if Trunc(r)<>RESULT_CONST_TWO then + _success := false; + r:=VALUE_TWO; + l:=Trunc(r); + if l<>RESULT_TWO then + _success:=false; + l:=Trunc(VALUE_TWO); + if l<>RESULT_TWO then + _success:=false; + + + if not _success then + fail; + WriteLn('Success!'); +end; +{$endif SKIP_CURRENCY_TEST} + + +Begin + test_trunc_real; + test_trunc_single; + test_trunc_double; +{$ifdef SKIP_CURRENCY_TEST} + Writeln('Skipping currency test because its not supported by theis compiler'); +{$else SKIP_CURRENCY_TEST} + test_trunc_currency; +{$endif SKIP_CURRENCY_TEST} +end. diff --git a/tests/test/jvm/tvarpara.pp b/tests/test/jvm/tvarpara.pp new file mode 100644 index 0000000000..e3947cebe5 --- /dev/null +++ b/tests/test/jvm/tvarpara.pp @@ -0,0 +1,75 @@ +program tvarpara; + +{$mode objfpc} + +uses + jdk15; + +procedure test(var c: char); +begin + if c<>'a' then + halt(1); + c:='b'; +end; + +procedure test(var c: widechar); +begin + if c<>'a' then + halt(2); + c:='b'; +end; + +procedure test(var i: int64); +begin +end; + +var + l: longint; +function f: longint; +begin + result:=l; + inc(l); +end; + +var + c: char; + w: widechar; + a: ansistring; + u: unicodestring; + s: shortstring; +begin + c:='a'; + test(c); + if c<>'b' then + halt(3); + a:='abc'; + test(a[1]); + if a<>'bbc' then + begin + u:=a; + jlsystem.fout.println(length(a)); + jlsystem.fout.println(length(u)); + jlsystem.fout.println(a=u); + jlsystem.fout.println(unicodestring(a)); + jlsystem.fout.println(unicodestring(ansistringclass(a).toString)); + halt(4); + end; + s:='cba'; + test(s[3]); + if s<>'cbb' then + begin + jlsystem.fout.println(unicodestring(s)); + halt(5); + end; + w:='a'; + test(w); + if w<>'b' then + halt(6); + u:='bac'; + l:=2; + test(u[f]); + if u<>'bbc' then + halt(7); + if l<>3 then + halt(8); +end. diff --git a/tests/test/jvm/tvirtclmeth.pp b/tests/test/jvm/tvirtclmeth.pp new file mode 100644 index 0000000000..eb936ab2ea --- /dev/null +++ b/tests/test/jvm/tvirtclmeth.pp @@ -0,0 +1,102 @@ +program tvirtclmeth; + +{$mode delphi} + +uses + jdk15; + +type + tvirtclmethbase = class + constructor create(l: longint); virtual; overload; + class function test(l: longint): ansistring; virtual; + end; + + tvirtclmethchild = class(tvirtclmethbase) + constructor create(l: longint); override; overload; + class function test(l: longint): ansistring; override; + procedure docreate; + end; + + tvirtclmethchild2 = class(tvirtclmethchild) + end; + + tcc = class of tvirtclmethbase; + + + constructor tvirtclmethbase.create(l: longint); + begin + if l<>1 then + raise jlexception.create('base class constructor but child expected'); + end; + + class function tvirtclmethbase.test(l: longint): ansistring; + begin + if l<>1 then + raise jlexception.create('base class but child expected'); + result:='base'; + end; + + constructor tvirtclmethchild.create(l: longint); + begin + if l<>2 then + raise jlexception.create('child class constructor but base expected'); + end; + + class function tvirtclmethchild.test(l: longint): ansistring; + begin + if l<>2 then + raise jlexception.create('child class but base expected'); + result:='child'; + end; + + + procedure tvirtclmethchild.docreate; + var + c: tvirtclmethchild; + begin + c:=self.create(2); + end; + +var + cc: tcc; + c: tvirtclmethbase; +begin + c:=tvirtclmethbase.create; + if c.test(1)<>'base' then + raise JLException.create('base 1 res'); + c:=tvirtclmethchild.create; + if c.test(2)<>'child' then + raise JLException.create('child 1 res'); + tvirtclmethchild(c).docreate; + cc:=tvirtclmethbase; + if cc.test(1)<>'base' then + raise JLException.create('base 2 res'); + cc:=tvirtclmethchild; + if cc.test(2)<>'child' then + raise JLException.create('child 2 res'); + cc:=tvirtclmethchild2; + if cc.test(2)<>'child' then + raise JLException.create('child2 1 res'); + + c:=tvirtclmethbase.create(1); + if not(c is tvirtclmethbase) then + raise JLException.create('base 4 res'); + c:=tvirtclmethchild.create(2); + if not(c is tvirtclmethchild) then + raise JLException.create('child 4 res'); + c:=tvirtclmethchild2.create(2); + if not(c is tvirtclmethchild2) then + raise JLException.create('child2 2 res'); + cc:=tvirtclmethbase; + c:=cc.create(1); + if not(c is tvirtclmethbase) then + raise JLException.create('base 4 res'); + cc:=tvirtclmethchild; + c:=cc.create(2); + if not(c is tvirtclmethchild) then + raise JLException.create('child 4 res'); + cc:=tvirtclmethchild2; + c:=cc.create(2); + if not(c is tvirtclmethchild2) then + raise JLException.create('child2 3 res'); +end. diff --git a/tests/test/jvm/twith.pp b/tests/test/jvm/twith.pp new file mode 100644 index 0000000000..818947bb9d --- /dev/null +++ b/tests/test/jvm/twith.pp @@ -0,0 +1,27 @@ +program twith; + +{$mode delphi} + +type + twithbase = class + end; + + twithchild = class(twithbase) + procedure test; virtual; + end; + +procedure twithchild.test; +begin +end; + + +function func: twithbase; +begin + result:=twithchild.create; +end; + + +begin + with twithchild(func) do + test; +end. diff --git a/tests/test/jvm/uenum.pp b/tests/test/jvm/uenum.pp new file mode 100644 index 0000000000..95f11d6e08 --- /dev/null +++ b/tests/test/jvm/uenum.pp @@ -0,0 +1,13 @@ +unit uenum; + +{$mode delphi} + +interface + +type + myenumjumps = (meja = 5, mejb = -5, mejc = 102); + myenum = (mea, meb, mec, med); + +implementation + +end. diff --git a/tests/test/jvm/unsupported.pp b/tests/test/jvm/unsupported.pp new file mode 100644 index 0000000000..80789b9ee1 --- /dev/null +++ b/tests/test/jvm/unsupported.pp @@ -0,0 +1,106 @@ +{ %norun } + +{ Note: these things *are* supported now, they just weren't when the test was + written (the purpose was to make sure the compiler didn't crash when trying + to compile these things, even though it generated invalid code for them) +} + +{$mode delphi} +{$t+} + +unit unsupported; + +interface + +type + tmyfunc = function(a: longint): longint; + tmyfuncobj = function(a: longint): longint of object; + +type + tc = class + function methfunc(a: longint): longint; + class procedure methproc; static; + end; + tcclass = class of tc; + +procedure test; + +implementation + + +function tc.methfunc(a: longint): longint; +begin +end; + +class procedure tc.methproc; +begin +end; + +function func(a: longint): longint; +begin + result:=a; +end; + +procedure test; +var + m: tmyfunc; + l: longint; + c: tc; + m2,m2a: tmyfuncobj; +begin + m:=func; + l:=m(6); + m2:=c.methfunc; + l:=m2(60); + if assigned(m) then ; + if assigned(m2) then ; + if @m=nil then ; + if @m2=nil then ; + m2a:=m2; +end; + +procedure testset; +var + a,b: set of byte; +begin + a:=[1..127]; + b:=[4..129]; + include(a,6); + a:=a*b+b-b>