paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-19 20:39:25 +02:00
Code Issues Packages Projects Releases Wiki Activity

* renamed Java-specific sstrings.inc/sstringh.inc to jsstrings.inc/

Browse Source 
jsstringh.inc -> use generic inc/sstrings.inc
  * added a bunch of extra {$ifdef FPC_HAS_XXX} protections around
    routines in inc/sstrings.inc and implemented those routines for
    the JVM target in java/jsstrings.inc
  * use the majority of the generic routine in sstrings.inc now also
    for the JVM target! Only a few changes were needed:
   o in a few places, calls to move() for copying shortstring->shortstring
     or shortstring->chararray were replaced with calls to a new inline
     helper that calls move() in the version in inc/sstrings.inc, and
     JLSystem.arraycopt() in in the version in java/jsstrings.inc
   o changed the currency argument to str() for the JVM target to constref
     so its address can be taken (has to be typecasted to int64 without
     changing the value), and similarly changed the temporary result
     inside that routine to an array of 1 elements so the address can be
     taken
   o don't typecast the real value to a record type in str_real for the
     JVM target, but work via an int64 instead to extract sign/mantissa/exp
   o everything else compiled and worked as is!!
  -> val, str, hexstr/octstr/binstr, delete, pos, insert, setstring and
     comparetext now all work for shortstrings on the JVM target

git-svn-id: branches/jvmbackend@18836 -
This commit is contained in:
Jonas Maebe 2011-08-24 22:11:43 +00:00
parent 56e724cea6
commit 1f96763b9d
21 changed files with 1264 additions and 209 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
.gitattributes vendored
View File

@ -9803,9 +9803,20 @@ 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/tstring1.pp svneol=native#text/plain
tests/test/jvm/tstrreal1.pp svneol=native#text/plain
tests/test/jvm/tstrreal2.pp svneol=native#text/plain
tests/test/jvm/tthreadvar.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/tval.inc svneol=native#text/plain
tests/test/jvm/tval.pp svneol=native#text/plain
tests/test/jvm/tval1.pp svneol=native#text/plain
tests/test/jvm/tval2.pp svneol=native#text/plain
tests/test/jvm/tval3.pp svneol=native#text/plain
tests/test/jvm/tval4.pp svneol=native#text/plain
tests/test/jvm/tval5.pp svneol=native#text/plain
tests/test/jvm/tvalc.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

21
rtl/inc/real2str.inc
View File

@ -33,6 +33,7 @@ const
maxDigits = 17;
{$else}
{$ifdef SUPPORT_DOUBLE}
{$ifndef cpujvm}
type
TSplitDouble = packed record
case byte of
@ -40,6 +41,7 @@ type
1: (words: Array[0..3] of word);
2: (cards: Array[0..1] of cardinal);
end;
{$endif}
const
maxDigits = 15;
{$else}
@ -62,6 +64,9 @@ type
TIntPartStack = array[1..maxDigits+1] of valReal;
var
{$ifdef jvm}
doublebits: int64;
{$endif}
roundCorr, corrVal, factor : valReal;
spos, endpos, fracCount: longint;
correct, currprec: longint;
@ -236,6 +241,14 @@ begin
{ correction used with comparing to avoid rounding/precision errors }
roundCorr := 1.0842021725e-19;
end;
else
begin
{ keep JVM byte code verifier happy }
maxlen:=0;
minlen:=0;
explen:=0;
roundCorr:=0;
end;
end;
{ check parameters }
{ default value for length is -32767 }
@ -281,11 +294,19 @@ begin
{$error sign/NaN/Inf not yet supported for big endian CPU's in str_real}
{$else SUPPORT_EXTENDED}
{$ifdef SUPPORT_DOUBLE}
{$ifdef cpujvm}
doublebits := JLDouble.doubleToLongBits(d);
sign := doublebits<0;
expMaximal := (doublebits shr (32+20)) and $7ff = 2047;
fraczero:= (((doublebits shr 32) and $fffff) = 0) and
(longint(doublebits)=0);
{$else cpujvm}
{ double, format (MSB): 1 Sign bit, 11 bit exponent, 52 bit mantissa }
sign := ((TSplitDouble(d).cards[0] shr 20) and $800) <> 0;
expMaximal := ((TSplitDouble(d).cards[0] shr 20) and $7ff) = 2047;
fraczero:= (TSplitDouble(d).cards[0] and $fffff = 0) and
(TSplitDouble(d).cards[1] = 0);
{$endif cpujvm}
{$else SUPPORT_DOUBLE}
{$ifdef SUPPORT_SINGLE}
{ single, format (MSB): 1 Sign bit, 8 bit exponent, 23 bit mantissa }

108
rtl/inc/sstrings.inc
View File

@ -15,6 +15,24 @@
subroutines for string handling
****************************************************************************}
{$ifndef FPC_HAS_SHORTSTR_SHORTSTR_INTERN_CHARMOVE}
{$define FPC_HAS_SHORTSTR_SHORTSTR_INTERN_CHARMOVE}
procedure fpc_shortstr_shortstr_intern_charmove(const src: shortstring; const srcindex: byte; var dst: shortstring; const dstindex, len: byte); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
move(src[srcindex],dst[dstindex],len);
end;
{$endif FPC_HAS_SHORTSTR_SHORTSTR_INTERN_CHARMOVE}
{$ifndef FPC_HAS_SHORTSTR_CHARARRAY_INTERN_CHARMOVE}
{$define FPC_HAS_SHORTSTR_CHARARRAY_INTERN_CHARMOVE}
procedure fpc_shortstr_chararray_intern_charmove(const src: shortstring; out dst: array of char; const len: sizeint); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
move(src[1],pchar(@dst)^,len);
end;
{$endif FPC_HAS_SHORTSTR_CHARARRAY_INTERN_CHARMOVE}
{$ifndef FPC_HAS_SHORTSTR_SETLENGTH}
{$define FPC_HAS_SHORTSTR_SETLENGTH}
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt);[Public,Alias : 'FPC_SHORTSTR_SETLENGTH']; compilerproc;
@ -42,7 +60,7 @@ begin
if count>length(s)-index then
count:=length(s)-index;
fpc_shortstr_Copy[0]:=chr(Count);
Move(s[Index+1],fpc_shortstr_Copy[1],Count);
fpc_shortstr_shortstr_intern_charmove(s,Index+1,fpc_shortstr_Copy,1,Count);
end;
{$endif FPC_HAS_SHORTSTR_COPY}
@ -59,7 +77,7 @@ begin
Count:=length(s)-Index+1;
s[0]:=Chr(length(s)-Count);
if Index<=Length(s) then
Move(s[Index+Count],s[Index],Length(s)-Index+1);
fpc_shortstr_shortstr_intern_charmove(s,Index+Count,s,Index,Length(s)-Index+1);
end;
end;
{$endif FPC_HAS_SHORTSTR_DELETE}
@ -88,8 +106,8 @@ begin
else
dec(indexlen,cut);
end;
move(s[Index],s[Index+srclen],indexlen);
move(Source[1],s[Index],srclen);
fpc_shortstr_shortstr_intern_charmove(s,Index,s,Index+srclen,indexlen);
fpc_shortstr_shortstr_intern_charmove(Source,1,s,Index,srclen);
s[0]:=chr(index+srclen+indexlen-1);
end;
{$endif FPC_HAS_SHORTSTR_INSERT}
@ -108,7 +126,7 @@ begin
indexlen:=Length(s)-Index+1;
if (sizeint(length(s))+1=sizeof(s)) and (indexlen>0) then
dec(indexlen);
move(s[Index],s[Index+1],indexlen);
fpc_shortstr_shortstr_intern_charmove(s,Index,s,Index+1,indexlen);
s[Index]:=Source;
s[0]:=chr(index+indexlen);
end;
@ -348,25 +366,35 @@ begin
end;
end;
{$ifndef FPC_HAS_QWORD_HEX_SHORTSTR}
{$define FPC_HAS_QWORD_HEX_SHORTSTR}
Function hexStr(Val:qword;cnt:byte):shortstring;
begin
hexStr:=hexStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_HEX_SHORTSTR}
{$ifndef FPC_HAS_QWORD_OCT_SHORTSTR}
{$define FPC_HAS_QWORD_OCT_SHORTSTR}
Function OctStr(Val:qword;cnt:byte):shortstring;
begin
OctStr:=OctStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_OCT_SHORTSTR}
{$ifndef FPC_HAS_QWORD_BIN_SHORTSTR}
{$define FPC_HAS_QWORD_BIN_SHORTSTR}
Function binStr(Val:qword;cnt:byte):shortstring;
begin
binStr:=binStr(int64(Val),cnt);
end;
{$endif FPC_HAS_QWORD_BIN_SHORTSTR}
{$ifndef FPC_HAS_HEXSTR_POINTER_SHORTSTR}
{$define FPC_HAS_HEXSTR_POINTER_SHORTSTR}
function hexstr(val : pointer) : shortstring;
var
i : longint;
@ -380,14 +408,17 @@ begin
v:=v shr 4;
end;
end;
{$endif FPC_HAS_HEXSTR_POINTER_SHORTSTR}
{$ifndef FPC_HAS_SPACE_SHORTSTR}
{$define FPC_HAS_SPACE_SHORTSTR}
function space (b : byte): shortstring;
begin
space[0] := chr(b);
FillChar (Space[1],b,' ');
end;
{$endif FPC_HAS_SPACE_SHORTSTR}
{*****************************************************************************
Str() Helpers
@ -442,8 +473,7 @@ begin
end;
{$endif}
{$ifndef FPC_SHORTSTR_ENUM_INTERN}
{$define FPC_SHORTSTR_ENUM_INTERN}
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_shortstr_enum_intern(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring): longint;
{ The following contains the TTypeInfo/TTypeData records from typinfo.pp
@ -595,10 +625,9 @@ begin
end;
{ also define alias for internal use in the system unit }
procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);external name 'FPC_SHORTSTR_BOOL';
procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);external {$ifndef cpujvm}name 'FPC_SHORTSTR_BOOL'{$endif};
procedure fpc_shortstr_currency(c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
procedure fpc_shortstr_currency({$ifdef cpujvm}constref{$endif} c : currency; len,f : SizeInt; out s : shortstring);[public,alias:'FPC_SHORTSTR_CURRENCY']; compilerproc;
const
MinLen = 8; { Minimal string length in scientific format }
var
@ -797,7 +826,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
@ -813,7 +842,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
@ -831,7 +860,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
@ -847,7 +876,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif CPU64}
@ -864,11 +893,11 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_chararray_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out a : array of char);compilerproc;
var
ss : shortstring;
@ -879,9 +908,9 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif not FPC_STR_ENUM_INTERN}
procedure fpc_chararray_bool(b : boolean;len:sizeint;out a : array of char);compilerproc;
var
@ -893,7 +922,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
@ -908,7 +937,7 @@ begin
maxlen:=length(ss)
else
maxlen:=high(a)+1;
move(ss[1],pchar(@a)^,maxlen);
fpc_shortstr_chararray_intern_charmove(ss,a,maxlen);
end;
{$endif FPC_HAS_STR_CURRENCY}
@ -1325,6 +1354,7 @@ begin
end;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint; [public, alias:'FPC_VAL_ENUM_SHORTSTR']; compilerproc;
function string_compare(const s1,s2:shortstring):sizeint;
@ -1411,6 +1441,7 @@ end;
{Redeclare fpc_val_enum_shortstr for internal use in the system unit.}
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint;external name 'FPC_VAL_ENUM_SHORTSTR';
{$endif FPC_STR_ENUM_INTERN}
function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; [public, alias:'FPC_VAL_CURRENCY_SHORTSTR']; compilerproc;
const
@ -1418,12 +1449,13 @@ const
Int64Edge : Int64 = ($7FFFFFFFFFFFFFFF - 10) div 10;
Int64Edge2 : Int64 = $7FFFFFFFFFFFFFFF div 10;
var
res : Int64;
{ to enable taking the address on the JVM target }
res : array[0..0] of Int64;
i,j,power,sign,len : longint;
FracOverflow : boolean;
begin
fpc_Val_Currency_ShortStr:=0;
res:=0;
res[0]:=0;
len:=Length(s);
Code:=1;
sign:=1;
@ -1454,9 +1486,9 @@ begin
begin
j:=Ord(s[code])-Ord('0');
{ check overflow }
if (res <= Int64Edge) or (res <= (MaxInt64 - j) div 10) then
if (res[0] <= Int64Edge) or (res[0] <= (MaxInt64 - j) div 10) then
begin
res:=res*10 + j;
res[0]:=res[0]*10 + j;
Inc(i);
end
else
@ -1465,9 +1497,9 @@ begin
exit
else
begin
if not FracOverflow and (j >= 5) and (res < MaxInt64) then
if not FracOverflow and (j >= 5) and (res[0] < MaxInt64) then
{ round if first digit of fractional part overflow }
Inc(res);
Inc(res[0]);
FracOverflow:=True;
end;
end;
@ -1528,24 +1560,26 @@ begin
if power > 0 then
begin
for i:=1 to power do
if res <= Int64Edge2 then
res:=res*10
if res[0] <= Int64Edge2 then
res[0]:=res[0]*10
else
exit;
end
else
for i:=1 to -power do
begin
if res <= MaxInt64 - 5 then
Inc(res, 5);
res:=res div 10;
if res[0] <= MaxInt64 - 5 then
Inc(res[0], 5);
res[0]:=res[0] div 10;
end;
res:=res*sign;
fpc_Val_Currency_ShortStr:=PCurrency(@res)^;
res[0]:=res[0]*sign;
fpc_Val_Currency_ShortStr:=PCurrency(@res[0])^;
Code:=0;
end;
{$ifndef FPC_HAS_SETSTRING_SHORTSTR}
{$define FPC_HAS_SETSTRING_SHORTSTR}
Procedure SetString (Out S : Shortstring; Buf : PChar; Len : SizeInt);
begin
If Len > High(S) then
@ -1556,7 +1590,10 @@ begin
Move (Buf[0],S[1],Len);
end;
end;
{$endif FPC_HAS_SETSTRING_SHORTSTR}
{$ifndef FPC_HAS_COMPARETEXT_SHORTSTR}
{$define FPC_HAS_COMPARETEXT_SHORTSTR}
function ShortCompareText(const S1, S2: shortstring): SizeInt;
var
c1, c2: Byte;
@ -1593,5 +1630,6 @@ begin
else
ShortCompareText := L1 - L2;
end;
{$endif FPC_HAS_COMPARETEXT_SHORTSTR}

37
rtl/java/compproc.inc
View File

@ -62,23 +62,28 @@ function fpc_char_copy(c:AnsiChar;index : SizeInt;count : SizeInt): shortstring
{ Str() support }
procedure fpc_ShortStr_sint(v : valsint;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_uint(v : valuint;len : SizeInt;out s : shortstring); compilerproc;
(*
{$ifndef FPUNONE}
procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring);compilerproc;
{$endif FPC_STR_ENUM_INTERN}
procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);compilerproc;
procedure fpc_ShortStr_Currency(c : currency; len,f : SizeInt; out s : shortstring); compilerproc;
{ constref is to enable taking the address of c }
procedure fpc_ShortStr_Currency({$ifdef cpujvm}constref{$endif} c : currency; len,f : SizeInt; out s : shortstring); compilerproc;
procedure fpc_chararray_sint(v : valsint;len : SizeInt;out a : array of AnsiChar); compilerproc;
procedure fpc_chararray_uint(v : valuint;len : SizeInt;out a : array of AnsiChar); compilerproc;
(*
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure fpc_AnsiStr_sint(v : valsint; Len : SizeInt; out S : AnsiString); compilerproc;
procedure fpc_AnsiStr_uint(v : valuint;Len : SizeInt; out S : AnsiString); compilerproc;
{$ifndef FPUNONE}
procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : ansistring); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_ansistr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:ansistring); compilerproc;
{$endif FPC_STR_ENUM_INTERN}
procedure fpc_ansistr_bool(b : boolean;len:sizeint;out s:ansistring); compilerproc;
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring); compilerproc;
@ -99,9 +104,9 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring)
{$ifndef CPU64}
procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring); compilerproc;
(*
procedure fpc_chararray_qword(v : qword;len : SizeInt;out a : array of AnsiChar); compilerproc;
procedure fpc_chararray_int64(v : int64;len : SizeInt;out a : array of AnsiChar); compilerproc;
(*
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure fpc_ansistr_qword(v : qword;len : SizeInt;out s : ansistring); compilerproc;
procedure fpc_ansistr_int64(v : int64;len : SizeInt;out s : ansistring); compilerproc;
@ -125,7 +130,9 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring)
{$ifndef FPUNONE}
procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc;
{$endif FPC_STR_ENUM_INTERN}
procedure fpc_widestr_bool(b : boolean;len:sizeint;out s:widestring);compilerproc;
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc;
@ -135,18 +142,23 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring)
{$ifndef FPUNONE}
procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_unicodestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:unicodestring);compilerproc;
{$endif FPC_STR_ENUM_INTERN}
procedure fpc_unicodestr_bool(b : boolean;len:sizeint;out s:unicodestring);compilerproc;
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc;
{$endif FPC_HAS_STR_CURRENCY}
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
*)
{$ifndef FPUNONE}
procedure fpc_chararray_Float(d : ValReal;len,fr,rt : SizeInt;out a : array of AnsiChar); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_chararray_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out a : array of AnsiChar);compilerproc;
{$endif}
procedure fpc_chararray_bool(b : boolean;len:sizeint;out a : array of AnsiChar);compilerproc;
{$ifdef FPC_HAS_STR_CURRENCY}
procedure fpc_chararray_Currency(c : Currency;len,fr : SizeInt;out a : array of AnsiChar);compilerproc;
@ -158,16 +170,22 @@ Function fpc_Val_Real_ShortStr(const s : shortstring; out code : ValSInt): ValRe
{$endif}
Function fpc_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_Shortstr(Const S: ShortString; out Code: ValSInt): ValUInt; compilerproc;
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint; compilerproc;
{$endif FPC_STR_ENUM_INTERN}
Function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
(*
{$ifndef FPUNONE}
Function fpc_Val_Real_AnsiStr(Const S : AnsiString; out Code : ValSInt): ValReal; compilerproc;
{$endif}
Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; out Code : ValSInt): ValUInt; compilerproc;
Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Currency; compilerproc;
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_Val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:valsint):longint; compilerproc;
{$endif}
*)
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
@ -177,23 +195,30 @@ function fpc_Val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:v
{$endif}
Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc;
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_val_Enum_WideStr (str2ordindex:pointer;const s:WideString;out code:valsint):longint;compilerproc;
{$endif FPC_STR_ENUM_INTERN}
Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc;
{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)}
{$ifndef VER2_2}
(*
{$ifndef FPUNONE}
Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; compilerproc;
{$endif}
Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; compilerproc;
Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; compilerproc;
{$ifndef FPC_STR_ENUM_INTERN}
function fpc_val_Enum_UnicodeStr(str2ordindex:pointer;const s:UnicodeString;out code:valsint):longint;compilerproc;
{$endif FPC_STR_ENUM_INTERN}
Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; compilerproc;
*)
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef CPU64}
Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; compilerproc;
Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; compilerproc;
(*
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_Val_qword_AnsiStr (Const S : AnsiString; out Code : ValSInt): qword;compilerproc;
Function fpc_Val_int64_AnsiStr (Const S : AnsiString; out Code : ValSInt): Int64; compilerproc;
@ -209,9 +234,11 @@ Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt):
Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; compilerproc;
{$endif VER2_2}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
*)
{$endif CPU64}
(*
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc;
Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc;
@ -409,7 +436,9 @@ procedure fpc_write_text_int64_iso(len : longint;var t : text;i : int64); compil
Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc;
Procedure fpc_Write_Text_Float_Iso(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_write_text_enum(typinfo,ord2strindex:pointer;len:sizeint;var t:text;ordinal:longint); compilerproc;
{$endif FPC_STR_ENUM_INTERN}
{$ifdef FPC_HAS_STR_CURRENCY}
Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Currency); compilerproc;
{$endif FPC_HAS_STR_CURRENCY}
@ -485,7 +514,9 @@ Procedure fpc_Read_Text_UInt(var f : Text; out u :ValUInt); compilerproc;
{$ifndef FPUNONE}
Procedure fpc_Read_Text_Float(var f : Text; out v :ValReal); compilerproc;
{$endif}
{$ifndef FPC_STR_ENUM_INTERN}
procedure fpc_read_text_enum(str2ordindex:pointer;var t:text;out ordinal:longint); compilerproc;
{$endif FPC_STR_ENUM_INTERN}
procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); compilerproc;
{$ifndef CPU64}
Procedure fpc_Read_Text_QWord(var f : text; out q : qword); compilerproc;

55
rtl/java/jsstringh.inc
View File

@ -50,59 +50,4 @@ type
class function CreateFromLiteralStringBytes(const u: unicodestring): TAnsiCharArray; static;
end;
//Function Pos (Const Substr : Ansistring; Const Source : Ansistring) : SizeInt;
//Function Pos (c : AnsiChar; Const s : Ansistring) : SizeInt;
//Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;
//Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;
//Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;
Function Pos (c : AnsiChar; Const s : Shortstring) : SizeInt;
Function Pos (const substr : ShortString; Const source : Shortstring) : SizeInt;
//Function Pos (c : char; Const s : UnicodeString) : SizeInt;
Function UpCase(const s : shortstring) : shortstring;
Function LowerCase(const s : shortstring) : shortstring;
//Function UpCase(c:UnicodeChar):UnicodeChar;
//Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
//Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
//Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
//Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
//
//function WideCharToString(S : PWideChar) : AnsiString;
//function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
//function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
//procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
//procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
//
//function UnicodeCharToString(S : PUnicodeChar) : AnsiString;
//function StringToUnicodeChar(const Src : AnsiString;Dest : PUnicodeChar;DestSize : SizeInt) : PUnicodeChar;
//function UnicodeCharLenToString(S : PUnicodeChar;Len : SizeInt) : AnsiString;
//procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
//procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
//
//procedure DefaultUnicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
//procedure DefaultAnsi2UnicodeMove(source:pchar;var dest:unicodestring;len:SizeInt);
//function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
//function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt;
//function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
//function Utf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
//function UTF8Encode(const s : Ansistring) : UTF8String; inline;
//function UTF8Encode(const s : UnicodeString) : UTF8String;
//function UTF8Decode(const s : UTF8String): UnicodeString;
//function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
//function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
//function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String;
//function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString;
//function WideStringToUCS4String(const s : WideString) : UCS4String;
//function UCS4StringToWideString(const s : UCS4String) : WideString;
//Procedure GetWideStringManager (Var Manager : TUnicodeStringManager);
//Procedure SetWideStringManager (Const New : TUnicodeStringManager);
//Procedure SetWideStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
//Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
//Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
//Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);

242
rtl/java/jsstrings.inc
View File

@ -196,93 +196,34 @@ begin
end;
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
{$define FPC_HAS_SHORTSTR_SHORTSTR_INTERN_CHARMOVE}
procedure fpc_shortstr_shortstr_intern_charmove(const src: shortstring; const srcindex: byte; var dst: shortstring; const dstindex, len: byte); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
if len>255 then
len:=255;
ShortstringClass(@s).curlen:=len;
JLSystem.arraycopy(JLObject(ShortstringClass(@src).fdata),srcindex-1,JLObject(ShortstringClass(@dst).fdata),dstindex-1,len);
end;
{$define FPC_HAS_SHORTSTR_CHARARRAY_INTERN_CHARMOVE}
procedure fpc_shortstr_chararray_intern_charmove(const src: shortstring; out dst: array of char; const len: sizeint); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
JLSystem.arraycopy(JLObject(ShortstringClass(@src).fdata),0,JLObject(@dst),0,len);
end;
{$define FPC_HAS_CHAR_TO_SHORTSTR}
procedure fpc_Char_To_ShortStr(out res : shortstring;const c : AnsiChar) compilerproc;
{
Converts a WideChar to a ShortString;
Converts an AnsiChar to a ShortString;
}
begin
setlength(res,1);
ShortstringClass(@res).fdata[0]:=c;
end;
Function fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc;
begin
if count<0 then
count:=0;
if index>1 then
dec(index)
else
index:=0;
if index>length(s) then
count:=0
else
if count>length(s)-index then
count:=length(s)-index;
ShortstringClass(@result).curlen:=count;
JLSystem.ArrayCopy(JLObject(ShortstringClass(@s).fdata),index,JLObject(ShortstringClass(@result).fdata),0,count);
end;
function fpc_char_copy(c:AnsiChar;index : SizeInt;count : SizeInt): shortstring;compilerproc;
begin
if (index=1) and (Count>0) then
fpc_char_Copy:=c
else
fpc_char_Copy:='';
end;
function upcase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=upcase(u);
end;
Function upCase(c:Char):Char;
var
u : unicodestring;
s: ansistring;
begin
u:=c;
s:=upcase(u);
c:=s[1];
end;
function lowercase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=lowercase(u);
end;
Function lowerCase(c:Char):Char; overload;
var
u : unicodestring;
s: ansistring;
begin
u:=c;
s:=lowercase(u);
c:=s[1];
end;
Function Pos (Const Substr : Shortstring; Const Source : Shortstring) : SizeInt;
{$define FPC_HAS_SHORTSTR_POS_SHORTSTR}
Function Pos (Const Substr : Shortstring; Const s : Shortstring) : SizeInt;
var
i,j,k,MaxLen, SubstrLen : SizeInt;
begin
@ -290,7 +231,7 @@ begin
SubstrLen:=Length(SubStr);
if SubstrLen>0 then
begin
MaxLen:=Length(source)-Length(SubStr);
MaxLen:=Length(s)-Length(SubStr);
i:=0;
while (i<=MaxLen) do
begin
@ -298,7 +239,7 @@ begin
j:=0;
k:=i-1;
while (j<SubstrLen) and
(ShortstringClass(@SubStr).fdata[j]=ShortstringClass(@Source).fdata[k]) do
(ShortstringClass(@SubStr).fdata[j]=ShortstringClass(@s).fdata[k]) do
begin
inc(j);
inc(k);
@ -313,26 +254,81 @@ begin
end;
{ Faster version for a char alone. Must be implemented because }
{ pos(c: char; const s: shortstring) also exists, so otherwise }
{ using pos(char,pchar) will always call the shortstring version }
{ (exact match for first argument), also with $h+ (JM) }
Function Pos (c : AnsiChar; Const s : ShortString) : SizeInt;
{$define FPC_HAS_SHORTSTR_POS_CHAR}
{Faster when looking for a single char...}
function pos(c:char;const s:shortstring):SizeInt;
var
i: SizeInt;
i : SizeInt;
begin
for i:=1 to length(s) do
for i:=0 to length(s)-1 do
begin
if ShortstringClass(@s).fdata[i-1]=c then
begin
pos:=i;
exit;
end;
if ShortStringClass(@s).fdata[i]=c then
begin
pos:=i+1;
exit;
end;
end;
pos:=0;
end;
{$define FPC_UPCASE_SHORTSTR}
function upcase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=upcase(u);
end;
{$define FPC_UPCASE_CHAR}
Function upCase(c:Char):Char;
var
u : unicodestring;
s: ansistring;
begin
u:=c;
s:=upcase(u);
c:=s[1];
end;
{$define FPC_LOWERCASE_SHORTSTR}
function lowercase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=lowercase(u);
end;
{$define FPC_LOWERCASE_CHAR}
Function lowerCase(c:Char):Char; overload;
var
u : unicodestring;
s: ansistring;
begin
u:=c;
s:=lowercase(u);
c:=s[1];
end;
{ defined as external aliases to the int64 versions }
{$define FPC_HAS_QWORD_OCT_SHORTSTR}
{$define FPC_HAS_QWORD_BIN_SHORTSTR}
{$define FPC_HAS_QWORD_HEX_SHORTSTR}
{$define FPC_HAS_HEXSTR_POINTER_SHORTSTR}
function hexstr(val : pointer) : shortstring;
begin
hexstr:=hexstr(JLObject(val).hashCode,sizeof(pointer)*2);
end;
{$define FPC_HAS_SPACE_SHORTSTR}
function space (b : byte): shortstring;
begin
setlength(result,b);
@ -345,35 +341,59 @@ end;
Str() Helpers
*****************************************************************************}
procedure fpc_shortstr_SInt(v : valSInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_SINT']; compilerproc;
{$define FPC_HAS_SETSTRING_SHORTSTR}
Procedure SetString (Out S : Shortstring; Buf : PChar; Len : SizeInt);
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_UInt(v : valUInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_UINT']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
end;
procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_QWORD']; compilerproc;
begin
int_str_unsigned(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
If Len > High(S) then
Len := High(S);
SetLength(S,Len);
If Buf<>Nil then
begin
JLSystem.arraycopy(JLObject(Buf),0,JLObject(ShortstringClass(@S).fdata),0,len);
end;
end;
procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_INT64']; compilerproc;
{$define FPC_HAS_COMPARETEXT_SHORTSTR}
function ShortCompareText(const S1, S2: shortstring): SizeInt;
var
c1, c2: Byte;
i: Integer;
L1, L2, Count: SizeInt;
P1, P2: PChar;
begin
int_str(v,s);
if length(s)<len then
s:=space(len-length(s))+s;
L1 := Length(S1);
L2 := Length(S2);
if L1 > L2 then
Count := L2
else
Count := L1;
i := 0;
P1 := @ShortstringClass(@S1).fdata[0];
P2 := @ShortstringClass(@S2).fdata[0];
c1 := 0;
c2 := 0;
while i < count do
begin
c1 := byte(p1[i]);
c2 := byte(p2[i]);
if c1 <> c2 then
begin
if c1 in [97..122] then
Dec(c1, 32);
if c2 in [97..122] then
Dec(c2, 32);
if c1 <> c2 then
Break;
end;
Inc(I);
end;
if i < count then
ShortCompareText := c1 - c2
else
ShortCompareText := L1 - L2;
end;
{ lie, implemented internally in the compiler }
{$define FPC_SHORTSTR_ENUM_INTERN}
{$define FPC_STR_ENUM_INTERN}

10
rtl/java/jsystemh.inc
View File

@ -386,6 +386,7 @@ Function Sseg:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
(*
function strpas(p:pchar):shortstring;{$ifdef SYSTEMINLINE}inline;{$endif}
function strlen(p:pchar):sizeint;external name 'FPC_PCHAR_LENGTH';
*)
{ Shortstring functions }
Procedure Delete(var s:shortstring;index:SizeInt;count:SizeInt);
@ -393,11 +394,13 @@ Procedure Insert(const source:shortstring;var s:shortstring;index:SizeInt);
Procedure Insert(source:Char;var s:shortstring;index:SizeInt);
Function Pos(const substr:shortstring;const s:shortstring):SizeInt;
Function Pos(C:Char;const s:shortstring):SizeInt;
(*
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function Pos (const Substr : ShortString; const Source : AnsiString) : SizeInt;
Procedure SetString (out S : AnsiString; Buf : PChar; Len : SizeInt);
Procedure SetString (out S : AnsiString; Buf : PWideChar; Len : SizeInt);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
*)
Procedure SetString (out S : Shortstring; Buf : PChar; Len : SizeInt);
function ShortCompareText(const S1, S2: shortstring): SizeInt;
Function upCase(const s:shortstring):shortstring;
@ -409,11 +412,10 @@ Function binStr(Val:Longint;cnt:byte):shortstring;
Function hexStr(Val:int64;cnt:byte):shortstring;
Function OctStr(Val:int64;cnt:byte):shortstring;
Function binStr(Val:int64;cnt:byte):shortstring;
Function hexStr(Val:qword;cnt:byte):shortstring;
Function OctStr(Val:qword;cnt:byte):shortstring;
Function binStr(Val:qword;cnt:byte):shortstring;
Function hexStr(Val:qword;cnt:byte):shortstring; {$ifdef cpujvm}external;{$endif}
Function OctStr(Val:qword;cnt:byte):shortstring; {$ifdef cpujvm}external;{$endif}
Function binStr(Val:qword;cnt:byte):shortstring; {$ifdef cpujvm}external;{$endif}
Function hexStr(Val:Pointer):shortstring;
*)
{ Char functions }
Function chr(b : byte) : Char; [INTERNPROC: fpc_in_chr_byte];

6
rtl/java/system.pp
View File

@ -80,12 +80,15 @@ const
function fpcGenericValueOf(__fpc_int: longint): JLEnum;
end;
{ generic versions are based on FPC/Delphi-style RTTI }
{$define FPC_STR_ENUM_INTERN}
{$i jrech.inc}
{$i jseth.inc}
{$i jpvarh.inc}
{$i jsystemh_types.inc}
{$i jtvarh.inc}
{$i sstringh.inc}
{$i jsstringh.inc}
{$i jdynarrh.inc}
{$i astringh.inc}
{$i jsystemh.inc}
@ -105,6 +108,7 @@ function min(a,b : longint) : longint;
end;
{$i jtvar.inc}
{$i jsstrings.inc}
{$i jrec.inc}
{$i jset.inc}
{$i jpvar.inc}

17
tests/test/jvm/testall.bat
View File

@ -184,3 +184,20 @@ ppcjvm -O2 -g tthreadvar
if %errorlevel% neq 0 exit /b %errorlevel%
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tthreadvar
if %errorlevel% neq 0 exit /b %errorlevel%
ppcjvm -O2 -g tstring1
if %errorlevel% neq 0 exit /b %errorlevel%
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tstring1
if %errorlevel% neq 0 exit /b %errorlevel%
ppcjvm -O2 -g tstrreal1
if %errorlevel% neq 0 exit /b %errorlevel%
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;.tstrreal1
if %errorlevel% neq 0 exit /b %errorlevel%
ppcjvm -O2 -g tstrreal2
if %errorlevel% neq 0 exit /b %errorlevel%
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tstrreal2
if %errorlevel% neq 0 exit /b %errorlevel%
ppcjvm -O2 -g -B tval
if %errorlevel% neq 0 exit /b %errorlevel%
java -Dfile.encoding=UTF-8 -cp ..\..\..\rtl\units\jvm-java;. tval
if %errorlevel% neq 0 exit /b %errorlevel%

8
tests/test/jvm/testall.sh
View File

@ -102,3 +102,11 @@ $PPC -O2 -g getbit
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. getbit
$PPC -O2 -g tthreadvar
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tthreadvar
$PPC -O2 -g tstring1
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tstring1
$PPC -O2 -g tstrreal1
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tstrreal1
$PPC -O2 -g tstrreal2
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tstrreal2
$PPC -O2 -g -B tval
java -Dfile.encoding=UTF-8 -cp ../../../rtl/units/jvm-java:. tval

80
tests/test/jvm/tstring1.pp Normal file
View File

@ -0,0 +1,80 @@
program tstring1;
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
function TestOK:boolean;
Const
TestStr: string[22]='HELLO, THIS IS A TEST ';
var
I : INTEGER;
U : STRING[1];
Q : STRING[100];
S : STRING[55];
T : STRING[60];
V : STRING;
begin
TestOk:=false;
T:='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890';
Insert (T, T, 1);
Delete (T, 55, 54);
S:=Copy (T, -5, 2); {'TH'}
U:=Copy (T, 7, 4); {'I'}
S:=S + U; {'THI'}
Q:=Copy (T, 32, 70); {'THE LAZY DOG 1234567890'}
Delete (Q, 2, 1); {'TE LAZY DOG 1234567890'}
Delete (Q, 100, 2); {'TE LAZY DOG 1234567890'}
Delete (Q, 3, -4); {'TE LAZY DOG 1234567890'}
Delete (Q, 3, 10); {'TE1234567890'}
{ writeln('TE1234567890 - ',Q);}
I:=Pos ('S', T); {25}
Insert(Copy(T,I,200),Q,3);{'TES OVER THE LAZY DOG 12345678901234567890'}
Delete (Q, 4, 6); {'TESTHE LAZY DOG 12345678901234567890}
S:=S + T [25]; {'THIS'}
S:=S + Copy (S, 3, -5) + Copy (S, 3, 2); {'THISIS'}
V:=T; {'THE QUICK BROWN FOX JUMPS OVER THE LAZY ..'}
Delete (V, 1, 36); {'AZY DOG 1234567890'}
if (Copy (V, -7, -1)='') and (Pos ('DOG', V)=5) then {TRUE}
Insert (V, S, 200); {'THISISAZY DOG 1234567890'}
U:=Copy (T, 44, 40); {' '}
Insert (U, S, 5); {'THIS ISAZY DOG 1234567890'}
I:=Pos ('ZY', S); {9}
Delete (S, I, -5); {'THIS ISAZY DOG 1234567890'}
Insert (Copy(S,5,1),S,8); {'THIS IS AZY DOG 1234567890'}
Delete (S, 10, 16); {'THIS IS A0'}
if S [Length (S)]='0' then {TRUE}
S:=S + Q; {'THIS IS A0TESTHE LAZY DOG 123456789012345...'}
V:=Copy (S, Length (S) - 19, 10); {'1234567890'}
if V=Copy (S, Length (S) - 9, 10) then {TRUE}
Delete (S, 15, 3 * Length (V)+2); {'THIS IS A0TEST'}
Insert ('', S, 0); {'THIS IS A0TEST'}
Insert(Copy(S,5,1),S,11); {'THIS IS A0 TEST'}
Insert ('HELLO', S, -4); {'HELLOTHIS IS A0 TEST'}
Insert (',', S, 6); {'HELLO,THIS IS A0 TEST'}
Delete (S, Pos ('TEST', S) - 2, 1); {'HELLO,THIS IS A TEST'}
Delete (Q, 1, 32767); {''}
Q:=Q + ' '; {' '}
Insert (Q, S, 7); {'HELLO, THIS IS A TEST'}
Insert (Q, S, 255); {'HELLO, THIS IS A TEST '}
if (S=TestStr) and (Q=' ') and (V='1234567890') and
(T='THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG 1234567890') then
TestOK:=true;
end;
begin
if TestOK then
WriteLn('Test OK')
else
begin
WriteLn('Test Failure!');
halt(1);
end;
end.

52
tests/test/jvm/tstrreal1.pp Normal file
View File

@ -0,0 +1,52 @@
program tstrreal1;
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
const
s: array[0..16] of string[13] =
('99999.900000',
'99999.990000',
'99999.999000',
'99999.999900',
'99999.999990',
'99999.999999',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000',
'100000.000000');
var
e,e2,e3: double;
s2: string;
c: longint;
begin
e := 100000.0;
e2 := 0.1;
c := 0;
repeat
e3 := e-e2;
str(e3:0:6,s2);
writeln(s2);
if s2 <> s[c] then
begin
write(' Error, should be '); writeln(s[c]);
halt(1);
end;
e2 := e2 /10.0;
inc(c);
until e2 < 1e-17;
end.

58
tests/test/jvm/tstrreal2.pp Normal file
View File

@ -0,0 +1,58 @@
program tstrreal2;
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
const
s: array[1..21] of string =
('10.00000000000000000',
'1.00000000000000000',
'0.10000000000000000',
'0.01000000000000000',
'0.00100000000000000',
'0.00010000000000000',
'0.00001000000000000',
'0.00000100000000000',
'0.00000010000000000',
'0.00000001000000000',
'0.00000000100000000',
'0.00000000010000000',
'0.00000000001000000',
'0.00000000000100000',
'0.00000000000010000',
'0.00000000000001000',
'0.00000000000000100',
'0.00000000000000010',
'0.00000000000000001',
'0.00000000000000000',
'0.00000000000000000');
var
e: extended;
c: longint;
s2: string;
lenadjust: longint;
begin
if sizeof(extended) = 8 then
lenadjust := 2
else
lenadjust := 0;
e := 10.0;
for c := 1 to 21 do
begin
str(e:0:17,s2);
writeln(s2);
if s2 <> copy(s[c],1,length(s[c])-lenadjust) then
begin
write(' Error, should be '); writeln(copy(s[c],1,length(s[c])-lenadjust));
halt(1);
end;
e := e / 10.0;
end;
end.

280
tests/test/jvm/tval.inc Normal file
View File

@ -0,0 +1,280 @@
{ Included by several source with different
definitions of the type
IntegerType
to check that the test is working for
all basic integer types }
procedure TestVal(comment,s : string; ExpectedRes : ValTestType; expected : IntegerType);
var
i : IntegerType;
err,err1 : word;
OK : boolean;
begin
OK:=false;
if not silent and (Comment<>'') then
Writeln(Comment);
Val(s,i,err);
if ExpectedRes=ValShouldFail then
begin
if err=0 then
begin
if not silent or not HasErrors then
begin
Write('Error: string ');write(Display(s));
writeln(' is a valid input for val function');
end;
HasErrors:=true;
end
else
begin
OK:=true;
if not silent then
begin
Write('Correct: string ');write(Display(s));
writeln(' is a not valid input for val function');
end;
end;
end
else if ExpectedRes=ValShouldSucceed then
begin
if err=0 then
begin
OK:=true;
if not silent then
begin
Write('Correct: string ');write(Display(s));
writeln(' is a valid input for val function');
end;
end
else
begin
if not silent or not HasErrors then
begin
Write('Error: string ');write(Display(s));
write(' is a not valid input for val function');
write(' error pos=');writeln(err);
end;
HasErrors:=true;
end;
end
else if ExpectedRes=ValShouldSucceedAfterRemovingTrail then
begin
if err=0 then
begin
if not silent or not HasErrors then
begin
Write('Error: string ');write(Display(s));
writeln(' is a valid input for val function');
end;
HasErrors:=true;
end
else
begin
err1:=err;
Val(Copy(s,1,err1-1),i,err);
if err=0 then
begin
OK:=true;
if not silent then
begin
Write('Correct: string ');write(Display(s));
write(' is a valid input for val function up to position ');writeln(err1);
end;
end
else
begin
if not silent or not HasErrors then
begin
Write('Error: string ');write(Display(Copy(s,1,err1-1)));
write(' is a not valid input for val function');
write(' error pos=');writeln(err);
end;
HasErrors:=true;
end;
end;
end;
if (err=0) and CheckVal and (i<>expected) then
begin
OK:=false;
if not silent or not HasErrors then
begin
Write('Error: string ');write(Display(s));
write(' value is ');write(jlong(i));write(' <> ');writeln(jlong(expected));
end;
HasErrors:=true;
end;
if OK then
inc(SuccessCount)
else
inc(FailCount);
end;
Procedure TestBase(Const Prefix : string;ValidChars : TCharSet);
var
i,j : longint;
st : string;
begin
CheckVal:=false;
Silent:=true;
for i:=0 to 255 do
begin
st:=prefix+chr(i);
if chr(i) in ValidChars then
TestVal('',st,ValShouldSucceed,0)
else
TestVal('',st,ValShouldFail,0);
end;
for i:=0 to 255 do
for j:=0 to 255 do
begin
st:=prefix+chr(i)+chr(j);
if (chr(i) in ValidChars) and
(chr(j) in ValidChars) then
TestVal('',st,ValShouldSucceed,0)
else
begin
if ((prefix<>'') or
(not (chr(i) in SpecialCharsFirst))) and
not (chr(j) in SpecialCharsSecond) then
TestVal('',st,ValShouldFail,0);
end;
end;
end;
Function TestAll : boolean;
var
S : string;
begin
TestVal('Testing empty string','',ValShouldFail,0);
TestVal('Testing string with #0',#0,ValShouldFail,0);
TestVal('Testing string with base prefix and no value','0x',ValShouldFail,0);
TestVal('Testing string with base prefix and no value','x',ValShouldFail,0);
TestVal('Testing string with base prefix and no value','X',ValShouldFail,0);
TestVal('Testing string with base prefix and no value','$',ValShouldFail,0);
TestVal('Testing string with base prefix and no value','%',ValShouldFail,0);
TestVal('Testing string with base prefix and no value','&',ValShouldFail,0);
TestVal('Testing string with base prefix and #0','0x'#0,ValShouldFail,0);
TestVal('Testing normal ''''0'''' string','0',ValShouldSucceed,0);
TestVal('Testing leading space',' 0',ValShouldSucceed,0);
TestVal('Testing leading 2 spaces',' 0',ValShouldSucceed,0);
TestVal('Testing leading 2 tabs',#9#9'0',ValShouldSucceed,0);
TestVal('Testing leading 3 spaces',' 0',ValShouldSucceed,0);
TestVal('Testing leading 3 tabs',#9#9#9'0',ValShouldSucceed,0);
TestVal('Testing leading space/tab combination',#9' 0',ValShouldSucceed,0);
TestVal('Testing leading space/tab combination',' '#9'0',ValShouldSucceed,0);
TestVal('Testing leading space/tab combination',' '#9' 0',ValShouldSucceed,0);
TestVal('Testing leading space/tab combination',#9' '#9' 0',ValShouldSucceed,0);
TestVal('Testing #0 following normal ''''0''','0'#0,ValShouldSucceed,0);
TestVal('Testing leading space with trailing #0',' 0'#0,ValShouldSucceed,0);
TestVal('Testing leading 2 spaces with trailing #0',' 0'#0,ValShouldSucceed,0);
TestVal('Testing leading 2 tabs with trailing #0',#9#9'0'#0,ValShouldSucceed,0);
TestVal('Testing leading 3 spaces with trailing #0',' 0'#0,ValShouldSucceed,0);
TestVal('Testing leading 3 tabs with trailing #0',#9#9#9'0'#0,ValShouldSucceed,0);
TestVal('Testing leading space/tab combination with trailing #0',#9' 0'#0,ValShouldSucceed,0);
TestVal('Testing leading space/tab combination with trailing #0',' '#9'0'#0,ValShouldSucceed,0);
TestVal('Testing leading space/tab combination with trailing #0',' '#9' 0'#0,ValShouldSucceed,0);
TestVal('Testing leading space/tab combination with trailing #0',#9' '#9' 0'#0,ValShouldSucceed,0);
TestVal('Testing trailing space','0 ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing 2 spaces','0 ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing 2 tabs','0'#9#9,ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing 3 spaces','0 ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing 3 tabs','0'#9#9#9,ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing space/tab combination','0'#9' ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing space/tab combination','0 '#9,ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing space/tab combination','0 '#9' ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing trailing space/tab combination','0'#9' '#9' ',ValShouldSucceedAfterRemovingTrail,0);
TestVal('Testing several zeroes',' 00'#0,ValShouldSucceed,0);
TestVal('Testing normal zero','0',ValShouldSucceed,0);
TestVal('Testing several zeroes','00',ValShouldSucceed,0);
TestVal('Testing normal zero with leading space',' 0',ValShouldSucceed,0);
TestVal('Testing several zeroes with leading space',' 00',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','0x0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','x0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','X0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','$0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','%0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and zero','&0',ValShouldSucceed,0);
TestVal('Testing string with base prefix and one','0x1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and one','x1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and one','X1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and one','$1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and one','%1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and one','&1',ValShouldSucceed,1);
TestVal('Testing string with base prefix and two','0x2',ValShouldSucceed,2);
TestVal('Testing string with base prefix and two','x2',ValShouldSucceed,2);
TestVal('Testing string with base prefix and two','X2',ValShouldSucceed,2);
TestVal('Testing string with base prefix and two','$2',ValShouldSucceed,2);
TestVal('Testing string with base prefix and two','%2',ValShouldFail,0);
TestVal('Testing string with base prefix and two','&2',ValShouldSucceed,2);
TestVal('Testing string with base prefix and seven','0x7',ValShouldSucceed,7);
TestVal('Testing string with base prefix and seven','x7',ValShouldSucceed,7);
TestVal('Testing string with base prefix and seven','X7',ValShouldSucceed,7);
TestVal('Testing string with base prefix and seven','$7',ValShouldSucceed,7);
TestVal('Testing string with base prefix and seven','%7',ValShouldFail,0);
TestVal('Testing string with base prefix and seven','&7',ValShouldSucceed,7);
TestVal('Testing string with base prefix and eight','0x8',ValShouldSucceed,8);
TestVal('Testing string with base prefix and eight','x8',ValShouldSucceed,8);
TestVal('Testing string with base prefix and eight','X8',ValShouldSucceed,8);
TestVal('Testing string with base prefix and eight','$8',ValShouldSucceed,8);
TestVal('Testing string with base prefix and eight','%8',ValShouldFail,0);
TestVal('Testing string with base prefix and eight','&8',ValShouldFail,0);
TestVal('Testing string with base prefix and nine','0x9',ValShouldSucceed,9);
TestVal('Testing string with base prefix and nine','x9',ValShouldSucceed,9);
TestVal('Testing string with base prefix and nine','X9',ValShouldSucceed,9);
TestVal('Testing string with base prefix and nine','$9',ValShouldSucceed,9);
TestVal('Testing string with base prefix and nine','%9',ValShouldFail,0);
TestVal('Testing string with base prefix and nine','&9',ValShouldFail,0);
TestVal('Testing string with base prefix and "a"','0xa',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "a"','xa',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "a"','Xa',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "a"','$a',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "a"','%a',ValShouldFail,0);
TestVal('Testing string with base prefix and "a"','&a',ValShouldFail,0);
TestVal('Testing string with base prefix and "A"','0xA',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "A"','xA',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "A"','XA',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "A"','$A',ValShouldSucceed,10);
TestVal('Testing string with base prefix and "A"','%A',ValShouldFail,0);
TestVal('Testing string with base prefix and "A"','&A',ValShouldFail,0);
TestVal('Testing string with base prefix and "f"','0xf',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "f"','xf',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "f"','Xf',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "f"','$f',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "f"','%f',ValShouldFail,0);
TestVal('Testing string with base prefix and "f"','&f',ValShouldFail,0);
TestVal('Testing string with base prefix and "F"','0xF',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "F"','xF',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "F"','XF',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "F"','$F',ValShouldSucceed,15);
TestVal('Testing string with base prefix and "F"','%F',ValShouldFail,0);
TestVal('Testing string with base prefix and "F"','&F',ValShouldFail,0);
// TestVal('Testing -zero','-0',ValShouldSucceed,0);
TestVal('Testing +zero','+0',ValShouldSucceed,0);
TestVal('Testing - zero','- 0',ValShouldFail,0);
TestVal('Testing + zero','+ 0',ValShouldFail,0);
TestVal('Testing --zero','--0',ValShouldFail,0);
TestVal('Testing ++zero','++0',ValShouldFail,0);
TestVal('Testing -+zero','-+0',ValShouldFail,0);
TestBase('%', ValidNumeralsBase2);
TestBase('&', ValidNumeralsBase8);
TestBase('', ValidNumeralsBase10);
TestBase('0x', ValidNumeralsBase16);
if HasErrors then
begin
Write(FailCount);write(' tests failed over ');writeln(SuccessCount+FailCount);
end
else
begin
Write('All tests succeeded count=');writeln(SuccessCount);
end;
TestAll:=HasErrors;
end;

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

@ -0,0 +1,43 @@
program tval;
{$ifdef cpujvm}
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
uses
{$ifdef cpujvm}
jdk15,
{$endif}
{ longint type, short string }
tval1,
{ dword type, short string }
tval2,
{ int64 type, short string }
tval3,
{ uint64 type, short string }
tval4,
{ common variables and functions }
tvalc;
begin
(*
if (paramcount>0) and
(paramstr(1)='verbose') then
silent:=false;
*)
TestAllVal1;
TestAllVal2;
TestAllVal3;
TestAllVal4;
if HasErrors then
begin
Writeln('Test tval failed');
Halt(1);
end;
end.

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

@ -0,0 +1,37 @@
unit tval1;
{$mode fpc}
interface
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
function TestAllVal1 : boolean;
implementation
uses
tvalc;
type
IntegerType = longint;
{$i tval.inc}
function TestAllVal1 : boolean;
begin
Writeln('Test val for longint type');
TestAllVal1:=TestAll;
end;
end.

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

@ -0,0 +1,37 @@
unit tval2;
{$mode fpc}
interface
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
function TestAllval2 : boolean;
implementation
uses
tvalc;
type
IntegerType = dword;
{$i tval.inc}
function TestAllval2 : boolean;
begin
Writeln('Test val for dword type');
TestAllval2:=TestAll;
end;
end.

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

@ -0,0 +1,37 @@
unit tval3;
{$mode fpc}
interface
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
function TestAllval3 : boolean;
implementation
uses
tvalc;
type
IntegerType = int64;
{$i tval.inc}
function TestAllval3 : boolean;
begin
Writeln('Test val for int64 type');
TestAllval3:=TestAll;
end;
end.

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

@ -0,0 +1,37 @@
unit tval4;
{$mode fpc}
interface
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
function TestAllval4 : boolean;
implementation
uses
tvalc;
type
IntegerType = qword;
{$i tval.inc}
function TestAllval4 : boolean;
begin
Writeln('Test val for qword type');
TestAllval4:=TestAll;
end;
end.

223
tests/test/jvm/tval5.pp Normal file
View File

@ -0,0 +1,223 @@
{$mode objfpc}
uses
sysutils;
procedure testcard;
const
h = 1;
hexch : array[0..15] of char='0123456789ABCDEF';
var
c: cardinal;
l: longint;
s: shortstring;
b, b2: byte;
ch, ch2: char;
{$ifdef cpu64}
caught: boolean;
{$endif cpu64}
begin
s:='$0fffffff';
for b := low(hexch) to high(hexch) do
begin
s[2]:=hexch[b];
val(s,c,l);
if (l<>0) then
halt(b+h);
end;
s:='$fffffff0';
for b := low(hexch) to high(hexch) do
begin
s[length(s)]:=hexch[b];
val(s,c,l);
if (l<>0) then
halt(b+16+h);
end;
setlength(s,10);
s[1]:='$';
for b2:= 1 to high(hexch) do
begin
for b := 2 to length(s)-1 do
s[b]:=hexch[b2];
for b := low(hexch) to high(hexch) do
begin
s[length(s)]:=hexch[b];
{$ifdef cpu64}
{$r+}
try
caught:=false;
{$endif cpu64}
val(s,c,l);
{$ifdef cpu64}
except on e : exception do
caught:=true;
end;
if not caught then
{$else cpu64}
if (l=0) then
{$endif}
halt(b2+32+h);
end;
end;
s:='0294967295';
for ch := '0' to '4' do
begin
s[1]:=ch;
val(s,c,l);
if (l<>0) then
halt(ord(ch)-ord('0')+b+49+h);
end;
s:='4294967290';
for ch := '0' to '5' do
begin
s[length(s)]:=ch;
val(s,c,l);
if (l<>0) then
halt(ord(ch)-ord('0')+b+54+h);
end;
s:='4294967290';
for ch := '6' to '9' do
begin
s[length(s)]:=ch;
{$ifdef cpu64}
{$r+}
try
caught:=false;
{$endif cpu64}
val(s,c,l);
{$ifdef cpu64}
except on e : exception do
caught:=true;
end;
if not caught then
{$else cpu64}
if (l=0) then
{$endif cpu64}
halt(ord(ch)-ord('0')+b+54+h);
end;
setlength(s,length('4294967295')+1);
for ch2:= '1' to '3' do
begin
for b := 1 to length(s)-1 do
s[b]:=ch2;
for ch := '0' to '9' do
begin
s[length(s)]:=ch;
{$ifdef cpu64}
{$r+}
try
caught:=false;
{$endif cpu64}
val(s,c,l);
{$ifdef cpu64}
except on e : exception do
caught:=true;
end;
if not caught then
{$else cpu64}
if (l=0) then
{$endif cpu64}
halt(ord(ch2)-ord('1')+65+h);
end;
end;
end;
procedure testqword;
const
h = 71;
hexch : array[0..15] of char='0123456789ABCDEF';
var
c: qword;
l: longint;
s: shortstring;
b, b2: byte;
ch, ch2: char;
begin
s:='$0fffffffffffffff';
for b := low(hexch) to high(hexch) do
begin
s[2]:=hexch[b];
val(s,c,l);
if (l<>0) then
halt(b+h);
end;
s:='$fffffffffffffff0';
for b := low(hexch) to high(hexch) do
begin
s[length(s)]:=hexch[b];
val(s,c,l);
if (l<>0) then
halt(b+16+h);
end;
setlength(s,18);
s[1]:='$';
for b2:= 1 to high(hexch) do
begin
for b := 2 to length(s)-1 do
s[b]:=hexch[b2];
for b := low(hexch) to high(hexch) do
begin
s[length(s)]:=hexch[b];
val(s,c,l);
if (l=0) then
halt(b2+32+h);
end;
end;
s:='18446744073709551615';
for ch := '0' to '1' do
begin
s[1]:=ch;
val(s,c,l);
if (l<>0) then
halt(ord(ch)-ord('0')+b+49+h);
end;
s:='18446744073709551615';
for ch := '0' to '5' do
begin
s[length(s)]:=ch;
val(s,c,l);
if (l<>0) then
halt(ord(ch)-ord('0')+b+54+h);
end;
s:='18446744073709551615';
for ch := '6' to '9' do
begin
s[length(s)]:=ch;
val(s,c,l);
if (l=0) then
halt(ord(ch)-ord('0')+b+54+h);
end;
setlength(s,length('18446744073709551615')+1);
for ch2:= '1' to '1' do
begin
for b := 1 to length(s)-1 do
s[b]:=ch2;
for ch := '0' to '9' do
begin
s[length(s)]:=ch;
val(s,c,l);
if (l=0) then
halt(ord(ch2)-ord('1')+61+h);
end;
end;
end;
begin
testcard;
testqword;
end.

74
tests/test/jvm/tvalc.pp Normal file
View File

@ -0,0 +1,74 @@
unit tvalc;
interface
{$ifdef cpujvm}
uses
jdk15;
{$macro on}
{$define write:=JLSystem.fout.print}
{$define writeln:=JLSystem.fout.println}
{$endif}
const
HasErrors : boolean = false;
Silent : boolean = true;
CheckVal : boolean = true;
SuccessCount : longint = 0;
FailCount : longint = 0;
type
TCharSet = set of char;
const
ValidNumeralsBase2 : TCHarSet = ['0'..'1'];
ValidNumeralsBase8 : TCHarSet = ['0'..'7'];
ValidNumeralsBase10 : TCHarSet = ['0'..'9'];
ValidNumeralsBase16 : TCHarSet = ['0'..'9','a'..'f','A'..'F'];
SpecialCharsFirst : TCharSet = [' ',#9,'x','X','$','&','%','+','-'];
SpecialCharsSecond : TCharSet = [#0];
type
ValTestType =
(ValShouldFail,
ValShouldSucceed,
ValShouldSucceedAfterRemovingTrail);
function Display(const s : string) : string;
implementation
function Display(const s : string) : string;
var
res,ordval : string;
i : longint;
quoted : boolean;
begin
res:='"';
quoted:=false;
for i:=1 to length(s) do
if ord(s[i])<32 then
begin
if quoted then
res:=res+'''';
str(ord(s[i]),ordval);
res:=res+'#'+ordval;
quoted:=false;
end
else
begin
if not quoted then
res:=res+'''';
quoted:=true;
res:=res+s[i];
end;
if quoted then
res:=res+'''';
res:=res+'"';
Display:=res;
end;
end.