paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-08-12 12:26:02 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ a bunch of jvm-specific tests: partly new, partly derived from existing

Browse Source 
tests
   o currently not yet integrated in the makefile system, use testall.sh/
     testall.bat to run the tests

git-svn-id: branches/jvmbackend@18777 -
This commit is contained in:
Jonas Maebe 2011-08-20 08:35:11 +00:00
parent f6ddabde85
commit 740e7ca6b5
51 changed files with 8921 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

50
.gitattributes vendored
View File

@ -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

260
tests/test/jvm/JavaClass.java Normal file
View File

@ -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()");
}
}

30
tests/test/jvm/classlist.pp Normal file
View File

@ -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.

43
tests/test/jvm/classmeth.pp Normal file
View File

@ -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.

33
tests/test/jvm/forw.pp Normal file
View File

@ -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.

22
tests/test/jvm/getbit.pp Normal file
View File

@ -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.

19
tests/test/jvm/nested.pp Normal file
View File

@ -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.

27
tests/test/jvm/outpara.pp Normal file
View File

@ -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.

30
tests/test/jvm/sort.pp Normal file
View File

@ -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.

309
tests/test/jvm/tabs.pp Normal file
View File

@ -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.

655
tests/test/jvm/taddset.pp Normal file
View File

@ -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.

658
tests/test/jvm/taddsetint.pp Normal file
View File

@ -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.

124
tests/test/jvm/tarray2.pp Normal file
View File

@ -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.

185
tests/test/jvm/tarray3.pp Normal file
View File

@ -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.

19
tests/test/jvm/tbyte.pp Normal file
View File

@ -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.

37
tests/test/jvm/tbytearrres.pp Normal file
View File

@ -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.

32
tests/test/jvm/tclassproptest.pp Normal file
View File

@ -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.

619
tests/test/jvm/tcnvstr1.pp Normal file
View File

@ -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.

156
tests/test/jvm/tcnvstr3.pp Normal file
View File

@ -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.

40
tests/test/jvm/tconst.pp Normal file
View File

@ -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.

34
tests/test/jvm/tdefpara.pp Normal file
View File

@ -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.

48
tests/test/jvm/tdynarrec.pp Normal file
View File

@ -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.

84
tests/test/jvm/tenum.pp Normal file
View File

@ -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.

2164
tests/test/jvm/test.pp Normal file
View File

File diff suppressed because it is too large Load Diff

182
tests/test/jvm/testall.bat Normal file
View File

@ -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%

96
tests/test/jvm/testall.sh Executable file
View File

@ -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

28
tests/test/jvm/testansi.pp Normal file
View File

@ -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.

78
tests/test/jvm/testintf.pp Normal file
View File

@ -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.

28
tests/test/jvm/testshort.pp Normal file
View File

@ -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.

679
tests/test/jvm/tformalpara.pp Normal file
View File

@ -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.

236
tests/test/jvm/tint.pp Normal file
View File

@ -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.

139
tests/test/jvm/tintstr.pp Normal file
View File

@ -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.

40
tests/test/jvm/tnestproc.pp Normal file
View File

@ -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.

43
tests/test/jvm/tprop.pp Normal file
View File

@ -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.

46
tests/test/jvm/tprop2.pp Normal file
View File

@ -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.

103
tests/test/jvm/tpvar.pp Normal file
View File

@ -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.

97
tests/test/jvm/tpvardelphi.pp Normal file
View File

@ -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.

53
tests/test/jvm/tpvarglobal.pp Normal file
View File

@ -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.

53
tests/test/jvm/tpvarglobaldelphi.pp Normal file
View File

@ -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.

255
tests/test/jvm/trange1.pp Normal file
View File

@ -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.

43
tests/test/jvm/trange2.pp Normal file
View File

@ -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.

149
tests/test/jvm/trange3.pp Normal file
View File

@ -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.

183
tests/test/jvm/tset1.pp Normal file
View File

@ -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.

98
tests/test/jvm/tset3.pp Normal file
View File

@ -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.

50
tests/test/jvm/ttrig.pp Normal file
View File

@ -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.

241
tests/test/jvm/ttrunc.pp Normal file
View File

@ -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.

75
tests/test/jvm/tvarpara.pp Normal file
View File

@ -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.

102
tests/test/jvm/tvirtclmeth.pp Normal file
View File

@ -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.

27
tests/test/jvm/twith.pp Normal file
View File

@ -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.

13
tests/test/jvm/uenum.pp Normal file
View File

@ -0,0 +1,13 @@
unit uenum;
{$mode delphi}
interface
type
myenumjumps = (meja = 5, mejb = -5, mejc = 102);
myenum = (mea, meb, mec, med);
implementation
end.

106
tests/test/jvm/unsupported.pp Normal file
View File

@ -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><a;
if 3 in a then ;
end;
procedure testnest;
var
a: longint;
procedure nest;
begin
a:=5;
end;
begin
nest;
end;
procedure testclassref;
var
cr: tcclass;
begin
cr:=tc;
end;
procedure callarrconst(a: array of const);
begin
if a[0].vtype = vtInteger then ;
if a[0].vinteger=4 then ;
end;
procedure testarrconst;
begin
callarrconst([32,1.0]);
end;
end.