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

* synchronised JVM versions of generic include files with current generic

Browse Source 
versions

git-svn-id: trunk@27839 -
This commit is contained in:
Jonas Maebe 2014-06-01 14:13:40 +00:00
parent 5e1a895e95
commit 5bc6a2e934
5 changed files with 942 additions and 228 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
rtl/java/jastrings.inc
View File

@ -246,7 +246,7 @@ end;
{$ifndef FPC_HAS_PCHAR_ANSISTR_INTERN_CHARMOVE}
{$define FPC_HAS_PCHAR_ANSISTR_INTERN_CHARMOVE}
procedure fpc_pchar_ansistr_intern_charmove(const src: pchar; const srcindex: sizeint; var dst: ansistring; const dstindex, len: sizeint); {$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif} {$ifdef SYSTEMINLINE}inline;{$endif}
procedure fpc_pchar_ansistr_intern_charmove(const src: pchar; const srcindex: sizeint; var dst: rawbytestring; const dstindex, len: sizeint); {$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif} {$ifdef SYSTEMINLINE}inline;{$endif}
begin
JLSystem.arraycopy(JLObject(src),srcindex,JLObject(AnsistringClass(dst).fdata),dstindex,len);
end;
@ -358,13 +358,18 @@ begin
{$else FPC_HAS_CPSTRING}
DestCP:=StringCodePage(DestS);
{$endif FPC_HAS_CPSTRING}
DestCP:=TranslatePlaceholderCP(DestCP);
sameCP:=true;
lowstart:=low(sarr);
{ skip empty strings }
while (lowstart<=high(sarr)) and
(sarr[lowstart]='') do
inc(lowstart);
if lowstart>high(sarr) then
begin
DestS:=''; { All source strings empty }
exit;
end;
DestCP:=TranslatePlaceholderCP(DestCP);
sameCP:=true;
tmpCP:=TranslatePlaceholderCP(StringCodePage(sarr[lowstart]));
for i:=lowstart+1 to high(sarr) do
begin
@ -423,7 +428,7 @@ begin
{ Calculate size of the result so we can do
a single call to SetLength() }
NewLen:=0;
for i:=low(sarr) to high(sarr) do
for i:=nonemptystart to high(sarr) do
inc(NewLen,length(sarr[i]));
SetLength(DestS,NewLen);
{ Concat all strings, except the string we already
@ -549,8 +554,8 @@ begin
result:=Length(S1);
exit;
end;
cp1:=StringCodePage(S1);
cp2:=StringCodePage(S2);
cp1:=TranslatePlaceholderCP(StringCodePage(S1));
cp2:=TranslatePlaceholderCP(StringCodePage(S2));
if cp1=cp2 then
begin
Maxi:=Length(S1);
@ -568,16 +573,11 @@ begin
else
begin
r1:=S1;
cp1:=TranslatePlaceholderCP(cp1);
if (cp1<>StringCodePage(r1)) then
SetCodePage(r1,DefaultSystemCodePage,false);
r2:=S2;
if (cp2<>StringCodePage(r2)) then
SetCodePage(r2,DefaultSystemCodePage,false);
//convert them to utf8 then compare
SetCodePage(r1,65001);
SetCodePage(r2,65001);
Result := fpc_AnsiStr_Compare(r1,r2);
Result:=fpc_AnsiStr_Compare(r1,r2);
end;
end;
@ -601,36 +601,33 @@ begin
exit;
end;
{ don't compare strings if one of them is empty }
if (pointer(S1)=nil) then
if (length(S1)=0) then
begin
result:=-Length(S2);
{ in the JVM, one string may be nil and the other may be empty -> the jlobject()
equals check may have failed even if both strings are technically empty }
result:=ord(length(S2)<>0);
exit;
end;
if (pointer(S2)=nil) then
if (length(S2)=0) then
begin
result:=Length(S1);
{ length(S1)<>0, we checked that above }
result:=1;
exit;
end;
cp1:=StringCodePage(S1);
cp2:=StringCodePage(S2);
if cp1<>cp2 then
begin
r1:=S1;
cp1:=TranslatePlaceholderCP(cp1);
if (cp1<>StringCodePage(r1)) then
SetCodePage(r1,DefaultSystemCodePage,false);
r2:=S2;
cp2:=TranslatePlaceholderCP(cp2);
if (cp2<>StringCodePage(r2)) then
SetCodePage(r2,DefaultSystemCodePage,false);
//convert them to utf8 then compare
SetCodePage(r1,65001);
SetCodePage(r2,65001);
end
else
cp1:=TranslatePlaceholderCP(StringCodePage(S1));
cp2:=TranslatePlaceholderCP(StringCodePage(S2));
if cp1=cp2 then
begin
r1:=s1;
r2:=s2;
end
else
begin
r1:=S1;
r2:=S2;
//convert them to utf8 then compare
SetCodePage(r1,65001);
SetCodePage(r2,65001);
end;
result:=ord(not JUArrays.equals(TJByteArray(AnsistringClass(r1).fdata),TJByteArray(AnsistringClass(r2).fdata)))
end;
@ -683,6 +680,7 @@ Function Fpc_Ansistr_Copy(Const S : RawByteString; Index,Size : SizeInt): RawByt
var
res: AnsistringClass;
begin
result:='';
dec(index);
if Index < 0 then
Index := 0;
@ -700,7 +698,6 @@ begin
JLSystem.ArrayCopy(JLObject(AnsistringClass(S).fdata),index,JLObject(res.fdata),0,size);
result:=ansistring(res);
end;
{ default function result is empty string }
end;
@ -773,7 +770,7 @@ end;
{ 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 : RawByteString) : SizeInt;
Function Pos(c : AnsiChar; Const s : RawByteString) : SizeInt;
var
i: SizeInt;
begin
@ -790,7 +787,7 @@ end;
{$define FPC_HAS_ANSISTR_OF_CHAR}
Function StringOfChar(c : char;l : SizeInt) : AnsiString;
Function StringOfChar(c : Ansichar;l : SizeInt) : AnsiString;
begin
SetLength(StringOfChar,l);
FillChar(AnsistringClass(result).fdata,l,c);

200
rtl/java/jcompproc.inc
View File

@ -29,12 +29,19 @@ type
fpc_normal_set_long = array[0..7] of longint;
fpc_stub_dynarray = array of byte;
{$ifdef FPC_HAS_FEATURE_HEAP}
{ Needed to solve overloading problem with call from assembler (PFV) }
Function fpc_getmem(size:ptruint):pointer;compilerproc;
Procedure fpc_freemem(p:pointer);compilerproc;
{$endif FPC_HAS_FEATURE_HEAP}
{ used by Default() in code blocks }
//procedure fpc_zeromem(p:pointer;len:ptruint);compilerproc;
//procedure fpc_fillmem(out data;len:ptruint;b : byte);compilerproc;
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
//procedure fpc_shortstr_assign(len:longint;sstr,dstr:pointer); compilerproc;
//procedure fpc_shortstr_assign(len:{$ifdef cpu16}smallint{$else}longint{$endif};sstr,dstr:pointer); compilerproc;
procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc;
{ JVM-specific }
function fpc_Char_To_ShortStr(const c : AnsiChar): ShortString; compilerproc;
@ -47,8 +54,9 @@ function fpc_shortstr_compare(const left,right:shortstring) : longint; compilerp
function fpc_shortstr_compare_equal(const left,right:shortstring) : longint; compilerproc;
procedure fpc_pchar_to_shortstr(out res : shortstring;p:pchar); compilerproc;
function fpc_pchar_length(p:pchar):longint; compilerproc;
function fpc_pwidechar_length(p:pwidechar):longint; compilerproc;
function fpc_pchar_length(p:pchar):sizeint; compilerproc;
function fpc_pwidechar_length(p:pwidechar):sizeint; compilerproc;
procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of AnsiChar; zerobased: boolean = true); compilerproc;
procedure fpc_shortstr_to_chararray(out res: array of AnsiChar; const src: ShortString); compilerproc;
@ -56,6 +64,20 @@ procedure fpc_shortstr_to_chararray(out res: array of AnsiChar; const src: Short
Function fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc;
function fpc_char_copy(c:AnsiChar;index : SizeInt;count : SizeInt): shortstring;compilerproc;
(*
{$ifdef FPC_HAS_FEATURE_DYNARRAYS}
function fpc_dynarray_copy(psrc : pointer;ti : pointer;
lowidx,count:tdynarrayindex) : fpc_stub_dynarray;compilerproc;
function fpc_dynarray_length(p : pointer) : tdynarrayindex; compilerproc;
function fpc_dynarray_high(p : pointer) : tdynarrayindex; compilerproc;
procedure fpc_dynarray_clear(var p : pointer;ti : pointer); compilerproc;
procedure fpc_dynarray_decr_ref(var p : pointer;ti : pointer); compilerproc;
procedure fpc_dynarray_incr_ref(p : pointer); compilerproc;
procedure fpc_dynarray_setlength(var p : pointer;pti : pointer; dimcount : sizeint;dims : pdynarrayindex); compilerproc;
procedure fpc_dynarray_assign(var dest : pointer; src : pointer; ti: pointer); compilerproc;
{$endif FPC_HAS_FEATURE_DYNARRAYS}
*)
{ 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;
@ -113,6 +135,43 @@ procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : RawByteStri
procedure fpc_UnicodeStr_int64(v : int64;len : SizeInt;out s : UnicodeString); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
procedure fpc_shortstr_longword(v : longword;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_longint(v : longint;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_chararray_longword(v : longword;len : SizeInt;out a : array of char); compilerproc;
procedure fpc_chararray_longint(v : longint;len : SizeInt;out a : array of char); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure fpc_ansistr_longword(v : longword;len : SizeInt;out s : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
procedure fpc_ansistr_longint(v : longint;len : SizeInt;out s : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
procedure fpc_widestr_longword(v : longword;len : SizeInt;out s : widestring); compilerproc;
procedure fpc_widestr_longint(v : longint;len : SizeInt;out s : widestring); compilerproc;
{$endif ndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
procedure fpc_UnicodeStr_longword(v : longword;len : SizeInt;out s : UnicodeString); compilerproc;
procedure fpc_UnicodeStr_longint(v : longint;len : SizeInt;out s : UnicodeString); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
procedure fpc_shortstr_word(v : word;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_shortstr_smallint(v : smallint;len : SizeInt;out s : shortstring); compilerproc;
procedure fpc_chararray_word(v : word;len : SizeInt;out a : array of char); compilerproc;
procedure fpc_chararray_smallint(v : smallint;len : SizeInt;out a : array of char); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure fpc_ansistr_word(v : word;len : SizeInt;out s : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
procedure fpc_ansistr_smallint(v : smallint;len : SizeInt;out s : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
procedure fpc_widestr_word(v : word;len : SizeInt;out s : widestring); compilerproc;
procedure fpc_widestr_smallint(v : smallint;len : SizeInt;out s : widestring); compilerproc;
{$endif ndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
procedure fpc_UnicodeStr_word(v : word;len : SizeInt;out s : UnicodeString); compilerproc;
procedure fpc_UnicodeStr_smallint(v : smallint;len : SizeInt;out s : UnicodeString); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU16 or CPU8}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$ifndef FPUNONE}
@ -213,21 +272,55 @@ Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt):
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
Function fpc_val_longint_shortstr(Const S: ShortString; out Code: ValSInt): LongInt; compilerproc;
Function fpc_val_longword_shortstr(Const S: ShortString; out Code: ValSInt): LongWord; compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_Val_longword_AnsiStr (Const S : RawByteString; out Code : ValSInt): LongWord;compilerproc;
Function fpc_Val_longint_AnsiStr (Const S : RawByteString; out Code : ValSInt): LongInt; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function fpc_Val_longword_WideStr (Const S : WideString; out Code : ValSInt): LongWord; compilerproc;
Function fpc_Val_longint_WideStr (Const S : WideString; out Code : ValSInt): LongInt; compilerproc;
{$endif ndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function fpc_Val_longword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): LongWord; compilerproc;
Function fpc_Val_longint_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): LongInt; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
Function fpc_val_smallint_shortstr(Const S: ShortString; out Code: ValSInt): SmallInt; compilerproc;
Function fpc_val_word_shortstr(Const S: ShortString; out Code: ValSInt): Word; compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Function fpc_Val_word_AnsiStr (Const S : RawByteString; out Code : ValSInt): Word;compilerproc;
Function fpc_Val_smallint_AnsiStr (Const S : RawByteString; out Code : ValSInt): SmallInt; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function fpc_Val_word_WideStr (Const S : WideString; out Code : ValSInt): Word; compilerproc;
Function fpc_Val_smallint_WideStr (Const S : WideString; out Code : ValSInt): SmallInt; compilerproc;
{$endif ndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function fpc_Val_word_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Word; compilerproc;
Function fpc_Val_smallint_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): SmallInt; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif CPU16 or CPU8}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
(*
Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc;
Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc;
*)
//Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc;
procedure fpc_AnsiStr_Concat (var DestS:RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
procedure fpc_AnsiStr_Concat_multi (var DestS:RawByteString;const sarr:array of RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
procedure fpc_AnsiStr_Concat (Var DestS : RawByteString;const S1,S2 : RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
procedure fpc_AnsiStr_Concat_multi (Var DestS : RawByteString;const sarr:array of RawByteString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
Function fpc_AnsiStr_To_AnsiStr (const S : RawByteString;cp : TSystemCodePage): RawByteString; compilerproc;
procedure fpc_AnsiStr_To_ShortStr (out res: shortstring; const S2 : RawByteString); compilerproc;
Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}): RawByteString; compilerproc;
Function fpc_Char_To_AnsiStr(const c : AnsiChar{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}): RawByteString; compilerproc;
Function fpc_PChar_To_AnsiStr(const p : PAnsiChar{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}): RawByteString; compilerproc;
Function fpc_CharArray_To_AnsiStr(const arr: array of ansichar; {$ifdef FPC_HAS_CPSTRING}cp : TSystemCodePage;{$endif FPC_HAS_CPSTRING}zerobased: boolean = true): RawByteString; compilerproc;
Function fpc_CharArray_To_AnsiStr(const arr: array of AnsiChar; {$ifdef FPC_HAS_CPSTRING}cp : TSystemCodePage;{$endif FPC_HAS_CPSTRING}zerobased: boolean = true): RawByteString; compilerproc;
procedure fpc_ansistr_to_chararray(out res: array of AnsiChar; const src: RawByteString); compilerproc;
function fpc_ansistr_setchar(const s: RawByteString; const index: longint; const ch: ansichar): RawByteString; compilerproc;
Function fpc_AnsiStr_Compare(const S1,S2 : RawByteString): SizeInt; compilerproc;
@ -236,7 +329,7 @@ Function fpc_AnsiStr_Compare_equal(const S1,S2 : RawByteString): SizeInt; compil
{ special declaration for the JVM }
Procedure fpc_AnsiStr_SetLength (Var S : RawByteString; l : SizeInt{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}); compilerproc;
Function Fpc_Ansistr_Copy(Const S : RawByteString; Index,Size : SizeInt): RawByteString;compilerproc;
Function fpc_ansistr_Copy (Const S : RawByteString; Index,Size : SizeInt): RawByteString;compilerproc;
{$ifdef EXTRAANSISHORT}
//Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): SizeInt; compilerproc;
{$endif EXTRAANSISHORT}
@ -245,10 +338,46 @@ Function Fpc_Ansistr_Copy(Const S : RawByteString; Index,Size : SizeInt): RawByt
unique as well }
//Function fpc_ansistr_Unique(Var S : jlobject): jlobject; compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{*****************************************************************************
Widestring support
*****************************************************************************}
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_WideStr_Decr_Ref (Var S : Pointer); compilerproc;
Procedure fpc_WideStr_Incr_Ref (Var S : Pointer); compilerproc;
procedure fpc_WideStr_To_ShortStr (out res: ShortString;const S2 : WideString); compilerproc;
Function fpc_ShortStr_To_WideStr (Const S2 : ShortString): WideString; compilerproc;
Function fpc_WideStr_To_AnsiStr (const S2 : WideString{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}): AnsiString; compilerproc;
Function fpc_AnsiStr_To_WideStr (Const S2 : RawByteString): WideString; compilerproc;
Procedure fpc_WideStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
Procedure fpc_WideStr_Concat (Var DestS : Widestring;const S1,S2 : WideString); compilerproc;
Procedure fpc_WideStr_Concat_multi (Var DestS : Widestring;const sarr:array of Widestring); compilerproc;
Function fpc_Char_To_WideStr(const c : Char): WideString; compilerproc;
Function fpc_PChar_To_WideStr(const p : pchar): WideString; compilerproc;
Function fpc_CharArray_To_WideStr(const arr: array of char; zerobased: boolean = true): WideString; compilerproc;
procedure fpc_widestr_to_chararray(out res: array of char; const src: WideString); compilerproc;
procedure fpc_widestr_to_widechararray(out res: array of widechar; const src: WideString); compilerproc;
Function fpc_WideStr_Compare(const S1,S2 : WideString): SizeInt; compilerproc;
Function fpc_WideStr_Compare_equal(const S1,S2 : WideString): SizeInt; compilerproc;
Procedure fpc_WideStr_RangeCheck(p: Pointer; index : SizeInt); compilerproc;
Procedure fpc_WideStr_SetLength (Var S : WideString; l : SizeInt); compilerproc;
Function fpc_widestr_Copy (Const S : WideString; Index,Size : SizeInt) : WideString;compilerproc;
{$ifndef FPC_WINLIKEWIDESTRING}
function fpc_widestr_Unique(Var S : Pointer): Pointer; compilerproc;
{$endif FPC_WINLIKEWIDESTRING}
Function fpc_UChar_To_WideStr(const c : WideChar): WideString; compilerproc;
Function fpc_PWideChar_To_WideStr(const p : pwidechar): widestring; compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif ndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
{*****************************************************************************
Unicode string support
*****************************************************************************}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
//Procedure fpc_UnicodeStr_Decr_Ref (Var S : Pointer); compilerproc;
//Procedure fpc_UnicodeStr_Incr_Ref (S : Pointer); compilerproc;
@ -258,6 +387,9 @@ Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString{$ifdef FPC_HAS_CPST
Function fpc_AnsiStr_To_UnicodeStr (Const S2 : RawByteString): UnicodeString; compilerproc;
Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc;
Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc;
{$ifndef CPUJVM}
Procedure fpc_UnicodeStr_Assign (Var S1 : Pointer;S2 : Pointer); compilerproc;
{$endif CPUJVM}
Procedure fpc_UnicodeStr_Concat (Var DestS : Unicodestring;const S1,S2 : UnicodeString); compilerproc;
Procedure fpc_UnicodeStr_Concat_multi (Var DestS : Unicodestring;const sarr:array of Unicodestring); compilerproc;
Function fpc_Char_To_UnicodeStr(const c : AnsiChar): UnicodeString; compilerproc;
@ -266,11 +398,14 @@ Function fpc_CharArray_To_UnicodeStr(const arr: array of AnsiChar; zerobased: bo
procedure fpc_unicodestr_to_chararray(out res: array of AnsiChar; const src: UnicodeString); compilerproc;
{ JVM-specific }
function fpc_unicodestr_setchar(const s: UnicodeString; const index: longint; const ch: unicodechar): UnicodeString; compilerproc;
procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; {$ifdef FPC_HAS_CPSTRING}cp : TSystemCodePage;{$endif FPC_HAS_CPSTRING} zerobased: boolean = true): AnsiString; compilerproc;
{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING}
Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
{$endif}
Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc;
procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: RawByteString); compilerproc;
@ -286,7 +421,7 @@ Function fpc_Char_To_UChar(const c : AnsiChar): UnicodeChar; compilerproc;
Function fpc_UChar_To_Char(const c : UnicodeChar): AnsiChar; compilerproc;
Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
Function fpc_UChar_To_AnsiStr(const c : UnicodeChar{$ifdef FPC_HAS_CPSTRING};cp : TSystemCodePage{$endif FPC_HAS_CPSTRING}): AnsiString; compilerproc;
function fpc_UChar_To_ShortStr(const c : UnicodeChar): shortstring; compilerproc;
function fpc_UChar_To_ShortStr(const c : WideChar): shortstring; compilerproc;
Function fpc_PWideChar_To_UnicodeStr(const p : pwidechar): unicodestring; compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
@ -299,6 +434,8 @@ procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar);
{ from text.inc }
Function fpc_get_input:PText;compilerproc;
Function fpc_get_output:PText;compilerproc;
Procedure fpc_textinit_iso(var t : Text;nr : DWord);compilerproc;
Procedure fpc_textclose_iso(var t : Text);compilerproc;
Procedure fpc_Write_End(var f:Text); compilerproc;
Procedure fpc_Writeln_End(var f:Text); compilerproc;
Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); compilerproc;
@ -323,6 +460,17 @@ procedure fpc_write_text_int64(len : longint;var t : text;i : int64); compilerpr
procedure fpc_write_text_qword_iso(len : longint;var t : text;q : qword); compilerproc;
procedure fpc_write_text_int64_iso(len : longint;var t : text;i : int64); compilerproc;
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
procedure fpc_write_text_longword(len : longint;var t : text;q : longword); compilerproc;
procedure fpc_write_text_longint(len : longint;var t : text;i : longint); compilerproc;
procedure fpc_write_text_longword_iso(len : longint;var t : text;q : longword); compilerproc;
procedure fpc_write_text_longint_iso(len : longint;var t : text;i : longint); compilerproc;
procedure fpc_write_text_word(len : longint;var t : text;q : word); compilerproc;
procedure fpc_write_text_smallint(len : longint;var t : text;i : smallint); compilerproc;
procedure fpc_write_text_word_iso(len : longint;var t : text;q : word); compilerproc;
procedure fpc_write_text_smallint_iso(len : longint;var t : text;i : smallint); compilerproc;
{$endif CPU16 or CPU8}
{$ifndef FPUNONE}
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;
@ -343,7 +491,7 @@ Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); comp
can appear inside the other arguments of writerstr }
procedure fpc_SetupWriteStr_Shortstr(var ReadWriteStrText: text; var s: shortstring); compilerproc;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
procedure fpc_SetupWriteStr_Ansistr(var ReadWriteStrText: text; var s: ansistring); compilerproc;
procedure fpc_SetupWriteStr_Ansistr(var ReadWriteStrText: text; var s: ansistring; cp: TSystemCodePage); compilerproc;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
procedure fpc_SetupWriteStr_Unicodestr(var ReadWriteStrText: text; var s: unicodestring); compilerproc;
@ -408,16 +556,28 @@ procedure fpc_Read_Text_WideChar(var f : Text; out wc: widechar); compilerproc;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
Procedure fpc_Read_Text_Char_Iso(var f : Text; out c : char); compilerproc;
Procedure fpc_Read_Text_SInt(var f : Text; out l :ValSInt); compilerproc;
Procedure fpc_Read_Text_SInt_Iso(var f : Text; out l : ValSInt); compilerproc;
Procedure fpc_Read_Text_UInt(var f : Text; out u :ValUInt); compilerproc;
Procedure fpc_Read_Text_UInt_Iso(var f : Text; out u : ValUInt); compilerproc;
{$ifndef FPUNONE}
Procedure fpc_Read_Text_Float(var f : Text; out v :ValReal); compilerproc;
Procedure fpc_Read_Text_Float_Iso(var f : Text; out v : ValReal); compilerproc;
{$endif}
procedure fpc_read_text_enum(str2ordindex:pointer;var t:text;out ordinal:longint); compilerproc;
procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); compilerproc;
procedure fpc_Read_Text_Currency_Iso(var f : Text; out v : Currency); compilerproc;
{$ifndef CPU64}
Procedure fpc_Read_Text_QWord(var f : text; out q : qword); compilerproc;
procedure fpc_Read_Text_QWord_Iso(var f : text; out q : qword); compilerproc;
Procedure fpc_Read_Text_Int64(var f : text; out i : int64); compilerproc;
procedure fpc_Read_Text_Int64_Iso(var f : text; out i : int64); compilerproc;
{$endif CPU64}
{$if defined(CPU16) or defined(CPU8)}
Procedure fpc_Read_Text_LongWord(var f : text; out q : longword); compilerproc;
Procedure fpc_Read_Text_LongInt(var f : text; out i : longint); compilerproc;
{$endif CPU16 or CPU8}
function fpc_GetBuf_Text(var f : Text) : pchar; compilerproc;
function fpc_GetBuf_TypedFile(var f : TypedFile) : pointer; compilerproc;
{$endif FPC_HAS_FEATURE_TEXTIO}
{$ifdef FPC_INCLUDE_SOFTWARE_MOD_DIV}
@ -426,6 +586,14 @@ function fpc_mod_dword(n,z : dword) : dword; compilerproc;
function fpc_div_longint(n,z : longint) : longint; compilerproc;
function fpc_mod_longint(n,z : longint) : longint; compilerproc;
{$endif FPC_INCLUDE_SOFTWARE_MOD_DIV}
{$ifdef FPC_INCLUDE_SOFTWARE_MUL}
function fpc_mul_integer(f1,f2 : integer;checkoverflow : boolean) : integer; compilerproc;
function fpc_mul_word(f1,f2 : word;checkoverflow : boolean) : word; compilerproc;
function fpc_mul_longint(f1,f2 : longint;checkoverflow : boolean) : longint; compilerproc;
function fpc_mul_dword(f1,f2 : dword;checkoverflow : boolean) : dword; compilerproc;
{$endif FPC_INCLUDE_SOFTWARE_MUL}
{ from int64.inc }
function fpc_div_qword(n,z : qword) : qword; compilerproc;
function fpc_mod_qword(n,z : qword) : qword; compilerproc;
@ -434,6 +602,8 @@ function fpc_div_int64(n,z : int64) : int64; compilerproc;
function fpc_mod_int64(n,z : int64) : int64; compilerproc;
function fpc_mul_qword(f1,f2 : qword;checkoverflow : longbool) : qword; compilerproc;
function fpc_mul_int64(f1,f2 : int64;checkoverflow : longbool) : int64; compilerproc;
function fpc_mul_dword_to_qword(f1,f2 : dword) : qword; compilerproc;
function fpc_mul_longint_to_int64(f1,f2 : longint) : int64; compilerproc;
*)
{$ifdef FPC_INCLUDE_SOFTWARE_SHIFT_INT64}
@ -492,15 +662,17 @@ procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc:
(*
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
procedure fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer); compilerproc;
Function fpc_PushExceptAddr (Ft: {$ifdef CPU16}SmallInt{$else}Longint{$endif};_buf,_newaddr : pointer): PJmp_buf ; compilerproc;
procedure fpc_Raiseexception (Obj : TObject; AnAddr : CodePointer; AFrame : Pointer); compilerproc;
Procedure fpc_PopAddrStack; compilerproc;
function fpc_PopObjectStack : TObject; compilerproc;
function fpc_PopSecondObjectStack : TObject; compilerproc;
Procedure fpc_ReRaise; compilerproc;
Function fpc_Catches(Objtype : TClass) : TObject; compilerproc;
{$ifdef VER2_6}
Procedure fpc_DestroyException(o : TObject); compilerproc;
function fpc_GetExceptionAddr : Pointer; compilerproc;
function fpc_GetExceptionAddr : CodePointer; compilerproc;
{$endif VER2_6}
function fpc_safecallhandler(obj: TObject): HResult; compilerproc;
function fpc_safecallcheck(res : hresult) : hresult; compilerproc; {$ifdef CPU86} register; {$endif}
procedure fpc_doneexception; compilerproc;
@ -653,12 +825,16 @@ Procedure fpc_reset_typed_iso(var f : TypedFile;Size : Longint); compilerproc;
Procedure fpc_rewrite_typed_iso(var f : TypedFile;Size : Longint); compilerproc;
Procedure fpc_typed_write(TypeSize : Longint;var f : TypedFile;const Buf); compilerproc;
Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
Procedure fpc_typed_read_iso(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc;
{$endif FPC_HAS_FEATURE_FILEIO}
{$ifdef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE}
function fpc_int64_to_double(i: int64): double; compilerproc;
function fpc_qword_to_double(q: qword): double; compilerproc;
{$endif FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE}
{$ifdef FPC_INCLUDE_SOFTWARE_LONGWORD_TO_DOUBLE}
function fpc_longword_to_double(i: longword): double; compilerproc;
{$endif FPC_INCLUDE_SOFTWARE_LONGWORD_TO_DOUBLE}
(*
function fpc_setjmp(var s : jmp_buf) : longint; compilerproc;
procedure fpc_longjmp(var s : jmp_buf; value : longint); compilerproc;

575
rtl/java/jsystem.inc
View File

@ -93,8 +93,8 @@ Const
Procedure HandleError (Errno : Longint); external name 'fpc_handleerror';
Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer); forward;
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer); forward;
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer); forward;
{$ifdef FPC_HAS_FEATURE_TEXTIO}
type
@ -178,6 +178,14 @@ function do_isdevice(handle:thandle):boolean;forward;
{$define SYSPROCDEFINED}
{$endif cpui386}
{$ifdef cpui8086}
{$ifdef SYSPROCDEFINED}
{$Error Can't determine processor type !}
{$endif}
{$i i8086.inc} { Case dependent, don't change }
{$define SYSPROCDEFINED}
{$endif cpui8086}
{$ifdef cpum68k}
{$ifdef SYSPROCDEFINED}
{$Error Can't determine processor type !}
@ -239,10 +247,14 @@ function do_isdevice(handle:thandle):boolean;forward;
{$Error Can't determine processor type !}
{$endif}
{$i armdefines.inc}
{$if defined(CPUARMV7EM) or defined(CPUARMV7M)}
{$if defined(CPUTHUMB2)}
{$i thumb2.inc} { Case dependent, don't change }
{$else}
{$i arm.inc} { Case dependent, don't change }
{$if defined(CPUTHUMB)}
{$i thumb.inc} { Case dependent, don't change }
{$else}
{$i arm.inc} { Case dependent, don't change }
{$endif}
{$endif}
{$define SYSPROCDEFINED}
{$endif cpuarm}
@ -255,6 +267,14 @@ function do_isdevice(handle:thandle):boolean;forward;
{$define SYSPROCDEFINED}
{$endif cpuavr}
{$ifdef cpumipsel}
{$ifdef SYSPROCDEFINED}
{$Error Can't determine processor type !}
{$endif}
{ there is no mipsel.inc, we use mips.inc instead }
{$i mips.inc} { Case dependent, don't change }
{$define SYSPROCDEFINED}
{$else not cpumipsel}
{$ifdef cpumips}
{$ifdef SYSPROCDEFINED}
{$Error Can't determine processor type !}
@ -262,14 +282,7 @@ function do_isdevice(handle:thandle):boolean;forward;
{$i mips.inc} { Case dependent, don't change }
{$define SYSPROCDEFINED}
{$endif cpumips}
{$ifdef cpumipsel}
{$ifdef SYSPROCDEFINED}
{$Error Can't determine processor type !}
{$endif}
{$i mipsel.inc} { Case dependent, don't change }
{$define SYSPROCDEFINED}
{$endif cpumipsel}
{$endif not cpumipsel}
{$ifdef cpujvm}
{$ifdef SYSPROCDEFINED}
@ -318,6 +331,12 @@ procedure fpc_zeromem(p:pointer;len:ptruint);
begin
FillChar(p^,len,0);
end;
procedure fpc_fillmem(out data;len:ptruint;b : byte);
begin
FillByte(data,len,b);
end;
{$endif cpujvm}
{ Include generic pascal only routines which are not defined in the processor
@ -424,6 +443,7 @@ function aligntoptr(p : pointer) : pointer;inline;
****************************************************************************}
{ Needs to be before RTTI handling }
{$i sstrings.inc}
{ requires sstrings.inc for initval }
@ -668,29 +688,36 @@ end;
Memory Management
****************************************************************************}
(*
Function Ptr(sel,off : Longint) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifndef FPC_SYSTEM_HAS_PTR}
Function Ptr(sel,off : {$ifdef CPU16}Word{$else}Longint{$endif}) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
ptr:=farpointer((sel shl 4)+off);
End;
{$endif not FPC_SYSTEM_HAS_PTR}
{$ifndef FPC_SYSTEM_HAS_CSEG}
Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
Cseg:=0;
End;
{$endif not FPC_SYSTEM_HAS_CSEG}
{$ifndef FPC_SYSTEM_HAS_DSEG}
Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
Dseg:=0;
End;
{$endif not FPC_SYSTEM_HAS_DSEG}
{$ifndef FPC_SYSTEM_HAS_SSEG}
Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif}
Begin
Sseg:=0;
End;
{$endif not FPC_SYSTEM_HAS_SSEG}
*)
{$push}
{$R-}
{$I-}
@ -700,11 +727,20 @@ End;
Miscellaneous
*****************************************************************************}
{$ifndef FPC_SYSTEM_HAS_STACKTOP}
(*
function StackTop: pointer;
begin
result:=StackBottom+StackLength;
end;
*)
{$endif FPC_SYSTEM_HAS_STACKTOP}
{$ifndef FPC_SYSTEM_HAS_GET_PC_ADDR}
{ This provides a dummy implementation
of get_pc_addr function, for CPU's that don't need
the instruction address to walk the stack. }
function get_pc_addr : pointer;
function get_pc_addr : codepointer;
begin
get_pc_addr:=nil;
end;
@ -715,9 +751,10 @@ end;
of get_caller_stackinfo procedure,
using get_caller_addr and get_caller_frame
functions. }
procedure get_caller_stackinfo(var framebp,addr : pointer);
procedure get_caller_stackinfo(var framebp : pointer; var addr : codepointer);
var
nextbp,nextaddr : pointer;
nextbp : pointer;
nextaddr : codepointer;
begin
nextbp:=get_caller_frame(framebp,addr);
nextaddr:=get_caller_addr(framebp,addr);
@ -768,7 +805,7 @@ begin
begin
l:=HInOutRes^;
HInOutRes^:=0;
HandleErrorAddrFrameInd(l,get_pc_addr,get_frame)
HandleErrorAddrFrameInd(l,get_pc_addr,get_frame);
end;
end;
@ -850,7 +887,7 @@ type
end;
TInitFinalTable = record
TableCount,
InitCount : longint;
InitCount : {$ifdef VER2_6}longint{$else}sizeint{$endif};
Procs : array[1..maxunits] of TInitFinalRec;
end;
PInitFinalTable = ^TInitFinalTable;
@ -864,13 +901,22 @@ var
procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; compilerproc;
var
i : longint;
i : ObjpasInt;
{$ifdef DEBUG}
pt : PInitFinalTable;
{$endif}
begin
{ call cpu/fpu initialisation routine }
fpc_cpuinit;
{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION}
{$ifdef DEBUG}
pt := PInitFinalTable(EntryInformation.InitFinalTable);
{$endif}
with PInitFinalTable(EntryInformation.InitFinalTable)^ do
{$else FPC_HAS_INDIRECT_MAIN_INFORMATION}
{$ifdef DEBUG}
pt := @InitFinalTable;
{$endif}
with InitFinalTable do
{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION}
begin
@ -932,33 +978,19 @@ Procedure FinalizeHeap;forward;
{$ifdef FPC_HAS_FEATURE_CONSOLEIO}
procedure SysFlushStdIO;
var
pstdout : ^Text;
begin
{ Show runtime error and exit }
pstdout:=@stdout;
If erroraddr<>nil Then
Begin
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
{ to get a nice symify }
Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
dump_stack(pstdout^,ErrorBase,ErrorAddr);
Writeln(pstdout^,'');
End;
{ Make sure that all output is written to the redirected file }
if Textrec(Output).Mode=fmOutput then
Flush(Output);
if Textrec(ErrOutput).Mode=fmOutput then
Flush(ErrOutput);
if Textrec(pstdout^).Mode=fmOutput then
Flush(pstdout^);
if Textrec(stdout).Mode=fmOutput then
Flush(stdout);
if Textrec(StdErr).Mode=fmOutput then
Flush(StdErr);
end;
{$endif FPC_HAS_FEATURE_CONSOLEIO}
Procedure InternalExit;
(*
var
@ -997,7 +1029,7 @@ Begin
Writeln(pstdout^,'Runtime error ',Errorcode,' at $',hexstr(erroraddr));
{ to get a nice symify }
Writeln(pstdout^,BackTraceStrFunc(Erroraddr));
dump_stack(pstdout^,ErrorBase);
dump_stack(pstdout^,ErrorBase,ErrorAddr);
Writeln(pstdout^,'');
End;
SysFlushStdIO;
@ -1023,16 +1055,22 @@ Begin
{$endif}
{$ifdef LINUX}
{sysfreemem already checks for nil}
sysfreemem(calculated_cmdline);
{ Do not try to do anything if the heap manager already reported an error }
if (errorcode<>203) and (errorcode<>204) then
sysfreemem(calculated_cmdline);
{$endif}
{$ifdef BSD}
sysfreemem(cmdline);
{ Do not try to do anything if the heap manager already reported an error }
if (errorcode<>203) and (errorcode<>204) then
sysfreemem(cmdline);
{$endif}
{$ifdef FPC_HAS_FEATURE_HEAP}
{$ifndef HAS_MEMORYMANAGER}
{$ifndef FPC_NO_DEFAULT_HEAP}
FinalizeHeap;
{$endif HAS_MEMORYMANAGER}
{$endif not FPC_NO_DEFAULT_HEAP}
{$endif not HAS_MEMORYMANAGER}
{$endif FPC_HAS_FEATURE_HEAP}
*)
End;
@ -1053,20 +1091,56 @@ end;
Procedure Halt(ErrNum: Longint);
Begin
ExitCode:=Errnum;
{$ifdef FPC_HAS_FEATURE_EXITCODE}
{$ifdef FPC_LIMITED_EXITCODE}
if ErrNum > maxExitCode then
ExitCode:=255
else
{$endif FPC_LIMITED_EXITCODE}
ExitCode:=ErrNum;
{$endif FPC_HAS_FEATURE_EXITCODE}
Do_Exit;
end;
(*
function SysBackTraceStr (Addr: Pointer): ShortString;
function SysBackTraceStr (Addr: CodePointer): ShortString;
begin
SysBackTraceStr:=' $'+hexstr(addr);
end;
*)
(*
function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
var
curr_frame,prev_frame: pointer;
curr_addr: codepointer;
i: sizeint;
begin
curr_frame:=get_frame;
curr_addr:=get_pc_addr;
prev_frame:=curr_frame;
get_caller_stackinfo(curr_frame,curr_addr);
i:=-skipframes;
while (i<count) and (curr_frame>prev_frame) and
(curr_frame<StackTop) do
begin
prev_frame:=curr_frame;
get_caller_stackinfo(curr_frame,curr_addr);
if (curr_addr=nil) or
(curr_frame=nil) then
break;
if (i>=0) then
frames[i]:=curr_addr;
inc(i);
end;
if i<0 then
result:=0
else
result:=i;
end;
*)
Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPU86} register; {$endif}
Procedure HandleErrorAddrFrame (Errno : longint;addr : CodePointer; frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPUI386} register; {$endif}
begin
If pointer(ErrorProc)<>Nil then
ErrorProc(Errno,addr,frame);
@ -1079,7 +1153,6 @@ begin
if ExceptAddrStack <> nil then
raise TObject(nil) at addr,frame;
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
Halt(errorcode);
*)
end;
@ -1087,7 +1160,7 @@ end;
{ This is used internally by system skip first level,
and generated the same output as before, when
HandleErrorFrame function was used internally. }
Procedure HandleErrorAddrFrameInd (Errno : longint;addr,frame : Pointer);
Procedure HandleErrorAddrFrameInd (Errno : longint;addr : CodePointer; frame : Pointer);
begin
get_caller_stackinfo (frame, addr);
HandleErrorAddrFrame (Errno,addr,frame);
@ -1104,23 +1177,29 @@ begin
end;
Procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
procedure fpc_handleerror (Errno : longint); compilerproc; [public,alias : 'FPC_HANDLEERROR'];
{
Procedure to handle internal errors, i.e. not user-invoked errors
Internal function should ALWAYS call HandleError instead of RunError.
}
begin
HandleErrorAddrFrame(Errno,get_pc_addr,get_frame);
HandleErrorAddrFrameInd(Errno,get_pc_addr,get_frame);
end;
procedure RunError(w : word);[alias: 'FPC_RUNERROR'];
var
bp : pointer;
pcaddr : codepointer;
begin
errorcode:=w;
(*
erroraddr:=get_caller_addr(get_frame,get_pc_addr,);
errorbase:=get_caller_frame(get_frame,get_pc_addr);
*)
pcaddr:=get_pc_addr;
bp:=get_frame;
get_caller_stackinfo(bp,pcaddr);
erroraddr:=pcaddr;
errorbase:=bp;
*)
Halt(errorcode);
end;
@ -1138,45 +1217,39 @@ End;
Procedure Error(RunTimeError : TRunTimeError);
begin
RunError(RuntimeErrorExitCodes[RunTimeError]);
end;
{$ifndef CPUJVM}
Procedure dump_stack(var f : text;bp,addr : Pointer);
Procedure dump_stack(var f : text;fp : Pointer; addr : CodePointer);
var
i : Longint;
prevbp : Pointer;
prevaddr : pointer;
prevfp : Pointer;
is_dev : boolean;
caller_frame,
caller_addr : Pointer;
Begin
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
try
{$endif FPC_HAS_FEATURE_EXCEPTIONS}
prevbp:=bp-1;
prevaddr:=nil;
{ Frame of this procedure acts as StackBottom, fp values below that are invalid. }
prevfp:=get_frame;
i:=0;
is_dev:=do_isdevice(textrec(f).Handle);
while bp > prevbp Do
{ sanity checks, new frame pointer must be always greater than the old one, further
it must point into the stack area, else something went wrong }
while (fp>prevfp) and (fp<StackTop) do
Begin
caller_addr := get_caller_addr(bp,addr);
caller_frame := get_caller_frame(bp,addr);
if (caller_addr=nil) then
prevfp:=fp;
get_caller_stackinfo(fp,addr);
if (addr=nil) then
break;
Writeln(f,BackTraceStrFunc(caller_addr));
if (caller_frame=nil) then
Writeln(f,BackTraceStrFunc(addr));
if (fp=nil) then
break;
Inc(i);
If ((i>max_frame_dump) and is_dev) or (i>256) Then
break;
prevbp:=bp;
prevaddr:=addr;
bp:=caller_frame;
addr:=caller_addr;
End;
{$ifdef FPC_HAS_FEATURE_EXCEPTIONS}
except
@ -1191,7 +1264,7 @@ procedure DumpExceptionBackTrace(var f:text);
var
FrameNumber,
FrameCount : longint;
Frames : PPointer;
Frames : PCodePointer;
begin
if RaiseList=nil then
exit;
@ -1211,7 +1284,7 @@ Type
PExitProcInfo = ^TExitProcInfo;
TExitProcInfo = Record
Next : PExitProcInfo;
SaveExit : Pointer;
SaveExit : CodePointer;
Proc : TProcedure;
End;
const
@ -1360,6 +1433,11 @@ end;
Abstract/Assert support.
*****************************************************************************}
procedure fpc_emptymethod;[public,alias : 'FPC_EMPTYMETHOD'];
begin
end;
procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR'];
begin
(*
@ -1403,7 +1481,7 @@ end;
{$i setjump.inc}
{$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
{$pop} //{$I-,R-,Q-} before 'procedure fpc_rangeerror'
{*****************************************************************************
@ -1424,8 +1502,10 @@ end;
{ Generic threadmanager }
{$i thread.inc}
{$ifndef FPC_SECTION_THREADVARS}
{ Generic threadvar support }
{$i threadvr.inc}
{$endif FPC_SECTION_THREADVARS}
{$ifdef DISABLE_NO_THREAD_MANAGER}
{ OS Dependent implementation }
@ -1441,13 +1521,49 @@ end;
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ Allow slash and backslash as separators }
procedure DoDirSeparators(p:Pchar);
procedure DoDirSeparators(var p: pchar; inplace: boolean = true);
var
i : longint;
len : sizeint;
newp : pchar;
begin
for i:=0 to strlen(p) do
len:=length(p);
newp:=nil;
for i:=0 to len do
if p[i] in AllowDirectorySeparators then
p[i]:=DirectorySeparator;
begin
if not inplace and
not assigned(newp) then
begin
getmem(newp,len+1);
move(p^,newp^,len+1);
p:=newp;
end;
p[i]:=DirectorySeparator;
end;
end;
procedure DoDirSeparators(var p: pwidechar; inplace: boolean = true);
var
i : longint;
len : sizeint;
newp : pwidechar;
begin
len:=length(p);
newp:=nil;
for i:=0 to len do
if (ord(p[i])<255) and
(ansichar(ord(p[i])) in AllowDirectorySeparators) then
begin
if not inplace and
not assigned(newp) then
begin
getmem(newp,(len+1)*2);
move(p^,newp^,(len+1)*2);
p:=newp;
end;
p[i]:=DirectorySeparator;
end;
end;
procedure DoDirSeparators(var p:shortstring);
@ -1458,11 +1574,129 @@ begin
if p[i] in AllowDirectorySeparators then
p[i]:=DirectorySeparator;
end;
procedure DoDirSeparators(var ps:RawByteString);
var
i : longint;
p : pchar;
unique : boolean;
begin
unique:=false;
for i:=1 to length(ps) do
if ps[i] in AllowDirectorySeparators then
begin
if not unique then
begin
uniquestring(ps);
p:=pchar(ps);
unique:=true;
end;
p[i-1]:=DirectorySeparator;
end;
end;
procedure DoDirSeparators(var ps:UnicodeString);
var
i : longint;
p : pwidechar;
unique : boolean;
begin
unique:=false;
for i:=1 to length(ps) do
if ps[i] in AllowDirectorySeparators then
begin
if not unique then
begin
uniquestring(ps);
p:=pwidechar(ps);
unique:=true;
end;
p[i-1]:=DirectorySeparator;
end;
end;
{$endif FPC_HAS_FEATURE_FILEIO}
{ OS dependent low level file functions }
{$ifdef FPC_HAS_FEATURE_FILEIO}
{$i sysfile.inc}
{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{$ifdef FPC_ANSI_TEXTFILEREC}
procedure do_open(var f; p: pansichar; flags: longint; pchangeable: boolean);
var
u: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
do_open(f,pwidechar(u),flags,true);
end;
procedure do_erase(p: pansichar; pchangeable: boolean);
var
u: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(p,DefaultFileSystemCodePage,u,length(p));
do_erase(pwidechar(u),true);
end;
procedure do_rename(src, dst: pansichar; srcchangeable, dstchangeable: boolean);
var
usrc, udst: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
widestringmanager.Ansi2UnicodeMoveProc(dst,DefaultFileSystemCodePage,udst,length(dst));
do_rename(pwidechar(usrc),pwidechar(udst),true,true);
end;
procedure do_rename(src: pansichar; dst: pwidechar; srcchangeable, dstchangeable: boolean);
var
usrc: UnicodeString;
begin
widestringmanager.Ansi2UnicodeMoveProc(src,DefaultFileSystemCodePage,usrc,length(src));
do_rename(pwidechar(usrc),dst,true,dstchangeable);
end;
{$endif FPC_ANSI_TEXTFILEREC}
{$endif not FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
{$ifndef FPC_ANSI_TEXTFILEREC}
procedure do_open(var f; p: pwidechar; flags: longint; pchangeable: boolean);
var
s: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
do_open(f,pansichar(s),flags,true);
end;
procedure do_erase(p: pwidechar; pchangeable: boolean);
var
s: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(p,s,DefaultFileSystemCodePage,length(p));
do_erase(pansichar(s),true);
end;
procedure do_rename(src, dst: pwidechar; srcchangeable, dstchangeable: boolean);
var
rsrc, rdst: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
widestringmanager.Unicode2AnsiMoveProc(dst,rdst,DefaultFileSystemCodePage,length(dst));
do_rename(pansichar(rsrc),pansichar(rdst),true,true);
end;
procedure do_rename(src: pwidechar; dst: pansichar; srcchangeable, dstchangeable: boolean);
var
rsrc: RawByteString;
begin
widestringmanager.Unicode2AnsiMoveProc(src,rsrc,DefaultFileSystemCodePage,length(src));
do_rename(pansichar(rsrc),dst,true,dstchangeable);
end;
{$endif not FPC_ANSI_TEXTFILEREC}
{$endif not FPCRTL_FILESYSTEM_TWO_BYTE_API}
{$endif FPC_HAS_FEATURE_FILEIO}
{ Text file }
@ -1486,55 +1720,182 @@ end;
{$ifdef FPC_HAS_FEATURE_FILEIO}
{ OS dependent dir functions }
{$i sysdir.inc}
{$endif FPC_HAS_FEATURE_FILEIO}
{$if defined(FPC_HAS_FEATURE_FILEIO) and defined(FPC_HAS_FEATURE_ANSISTRINGS)}
Procedure getdir(drivenr:byte;Var dir:ansistring);
{ this is needed to also allow ansistrings, the shortstring version is
OS dependent }
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
{$ifndef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
procedure do_getdir(drivenr : byte;var dir : rawbytestring);
var
s : shortstring;
u: unicodestring;
begin
getdir(drivenr,s);
Do_getdir(drivenr,u);
widestringmanager.Unicode2AnsiMoveProc(pwidechar(u),dir,DefaultRTLFileSystemCodePage,length(u));
end;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Procedure MkDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_mkdir(ToSingleByteFileSystemEncodedFileName(S));
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_mkdir(S);
{$endif}
end;
Procedure RmDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_rmdir(ToSingleByteFileSystemEncodedFileName(S));
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_rmdir(S);
{$endif}
End;
Procedure ChDir(Const s: RawByteString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_chdir(ToSingleByteFileSystemEncodedFileName(S));
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Do_chdir(S);
{$endif}
End;
Procedure getdir(drivenr:byte;Var dir:rawbytestring);
begin
Do_getdir(drivenr,dir);
{ we should return results in the DefaultRTLFileSystemCodePage -> convert if
necessary }
setcodepage(dir,DefaultRTLFileSystemCodePage,true);
end;
{ the generic shortstring ones are only implemented elsewhere for systems *not*
supporting ansi/unicodestrings; for now assume there are no systems that
support unicodestrings but not ansistrings }
{ avoid double string conversions }
{$ifdef FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
function GetDirStrFromShortstring(const s: shortstring): RawByteString;
begin
GetDirStrFromShortstring:=ToSingleByteFileSystemEncodedFileName(ansistring(s));
end;
{$else FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
function GetDirStrFromShortstring(const s: shortstring): UnicodeString;
begin
GetDirStrFromShortstring:=s;
end;
{$endif FPCRTL_FILESYSTEM_SINGLE_BYTE_API}
Procedure MkDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_mkdir(GetDirStrFromShortstring(S));
End;
Procedure RmDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_rmdir(GetDirStrFromShortstring(S));
End;
Procedure ChDir(Const s: shortstring);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
exit;
Do_chdir(GetDirStrFromShortstring(S));
End;
Procedure getdir(drivenr:byte;Var dir:shortstring);
var
s: rawbytestring;
begin
Do_getdir(drivenr,s);
if length(s)<=high(dir) then
dir:=s
else
inoutres:=3;
end;
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$if defined(FPC_HAS_FEATURE_WIDESTRINGS)}
{$ifndef FPCRTL_FILESYSTEM_TWO_BYTE_API}
{ overloads required for mkdir/rmdir/chdir to ensure that the string is
converted to the right code page }
procedure do_mkdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_mkdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_rmdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_rmdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_chdir(const s: unicodestring); {$ifdef SYSTEMINLINE}inline;{$endif}
begin
do_chdir(ToSingleByteFileSystemEncodedFileName(s));
end;
procedure do_getdir(drivenr : byte;var dir : unicodestring);
var
s: rawbytestring;
begin
Do_getdir(drivenr,s);
dir:=s;
end;
{$endif}
{$endif FPCRTL_FILESYSTEM_TWO_BYTE_API}
{$if defined(FPC_HAS_FEATURE_FILEIO)}
Procedure MkDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Procedure MkDir(Const s: UnicodeString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
if (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
MkDir(@buffer[0],length(s));
Do_mkdir(S);
End;
Procedure RmDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Procedure RmDir(Const s: UnicodeString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
if (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
RmDir(@buffer[0],length(s));
Do_rmdir(S);
End;
Procedure ChDir(Const s: String);
Var
Buffer: Array[0..255] of Char;
Procedure ChDir(Const s: UnicodeString);[IOCheck];
Begin
If (s='') or (InOutRes <> 0) then
if (s='') or (InOutRes <> 0) then
exit;
Move(s[1], Buffer, Length(s));
Buffer[Length(s)] := #0;
ChDir(@buffer[0],length(s));
Do_chdir(S);
End;
{$endif}
Procedure getdir(drivenr:byte;Var dir:unicodestring);
begin
Do_getdir(drivenr,dir);
end;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
{*****************************************************************************
Resources support

132
rtl/java/jsystemh.inc
View File

@ -297,15 +297,15 @@ function RolQWord(Const AValue : QWord;const Dist : Byte): QWord;{$ifdef SYSTEMI
{$ifdef FPC_HAS_INTERNAL_SAR}
{$if defined(cpux86_64) or defined(cpui386)}
{$if defined(cpux86_64) or defined(cpui386) or defined(mips) or defined(mipsel) or defined(sparc)}
{$define FPC_HAS_INTERNAL_SAR_BYTE}
{$define FPC_HAS_INTERNAL_SAR_WORD}
{$endif defined(cpux86_64) or defined(cpui386)}
{$endif defined(cpux86_64) or defined(cpui386) or defined(mips) or defined(mipsel) or defined(sparc)}
{ currently, all supported CPUs have an internal 32 bit sar implementation }
{ $if defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)}
{ $if defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64) or defined(mips) or defined(mipsel)}
{$define FPC_HAS_INTERNAL_SAR_DWORD}
{ $endif defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)}
{ $endif defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64) or defined(mips) or defined(mipsel)}
{$if defined(cpux86_64) or defined(powerpc64)}
{$define FPC_HAS_INTERNAL_SAR_QWORD}
@ -341,7 +341,7 @@ function fpc_SarInt64(Const AValue : Int64;const Shift : Byte): Int64;compilerpr
{$endif FPC_HAS_INTERNAL_SAR_QWORD}
{$ifdef FPC_HAS_INTERNAL_BSF}
{$if defined(cpui386) or defined(cpux86_64)}
{$if defined(cpui386) or defined(cpux86_64) or defined(cpuarm)}
{$define FPC_HAS_INTERNAL_BSF_BYTE}
{$define FPC_HAS_INTERNAL_BSF_WORD}
{$define FPC_HAS_INTERNAL_BSF_DWORD}
@ -362,6 +362,7 @@ function fpc_SarInt64(Const AValue : Int64;const Shift : Byte): Int64;compilerpr
{$endif}
{$endif}
{$ifdef FPC_HAS_INTERNAL_BSF_BYTE}
function BsfByte(Const AValue: Byte): Byte;[internproc:fpc_in_bsf_x];
{$else}
@ -376,34 +377,34 @@ function BsrByte(Const AValue: Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ifdef FPC_HAS_INTERNAL_BSF_WORD}
function BsfWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsf_x];
{$else}
function BsfWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsfWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSF_WORD}
{$ifdef FPC_HAS_INTERNAL_BSR_WORD}
function BsrWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsrWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrWord(Const AValue: Word): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSR_WORD}
{$ifdef FPC_HAS_INTERNAL_BSF_DWORD}
function BsfDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsf_x];
{$else}
function BsfDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsfDWord(Const AValue : DWord): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSF_DWORD}
{$ifdef FPC_HAS_INTERNAL_BSR_DWORD}
function BsrDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsrDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrDWord(Const AValue : DWord): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSR_DWORD}
{$ifdef FPC_HAS_INTERNAL_BSF_QWORD}
function BsfQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsf_x];
{$else}
function BsfQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsfQWord(Const AValue : QWord): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSF_QWORD}
{$ifdef FPC_HAS_INTERNAL_BSR_QWORD}
function BsrQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsr_x];
{$else}
function BsrQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}
function BsrQWord(Const AValue : QWord): {$ifdef CPU16}byte{$else}cardinal{$endif};{$ifdef SYSTEMINLINE}inline;{$endif}
{$endif FPC_HAS_INTERNAL_BSR_QWORD}
function PopCnt(Const AValue: Byte): Byte;[internproc:fpc_in_popcnt_x];
@ -422,7 +423,7 @@ function PopCnt(Const AValue : QWord): QWord;[internproc:fpc_in_popcnt_x];
Addr/Pointer Handling
****************************************************************************}
(*
Function ptr(sel,off:Longint):farpointer;[internconst:fpc_in_const_ptr];{$ifdef SYSTEMINLINE}inline;{$endif}
Function ptr(sel,off:{$ifdef CPU16}Word{$else}Longint{$endif}):farpointer;[internconst:fpc_in_const_ptr];{$ifdef SYSTEMINLINE}inline;{$endif}
Function Cseg:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Dseg:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
Function Sseg:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
@ -467,7 +468,12 @@ Function binStr(Val:int64;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}
{$ifdef CPUI8086}
Function hexStr(Val:NearPointer):shortstring;
Function hexStr(Val:FarPointer):shortstring;
{$else CPUI8086}
Function hexStr(Val:Pointer):shortstring;
{$endif CPUI8086}
{ Char functions }
Function chr(b : byte) : Char; [INTERNPROC: fpc_in_chr_byte];
@ -495,8 +501,11 @@ function StringElementSize(const S : RawByteString): Word; overload;
function StringRefCount(const S : RawByteString): SizeInt; overload;
procedure SetCodePage(var s : RawByteString; CodePage : TSystemCodePage; Convert : Boolean = True);
procedure SetMultiByteConversionCodePage(CodePage: TSystemCodePage);
procedure SetMultiByteFileSystemCodePage(CodePage: TSystemCodePage);
procedure SetMultiByteRTLFileSystemCodePage(CodePage: TSystemCodePage);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{****************************************************************************
WideString Handling
****************************************************************************}
@ -514,9 +523,20 @@ procedure SetMultiByteConversionCodePage(CodePage: TSystemCodePage);
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure Assign(out f:File;const Name:string);
Procedure Assign(out f:File;p:pchar);
Procedure Assign(out f:File;c:char);
Procedure Assign(out f:File;const Name: ShortString);
Procedure Assign(out f:File;const p: PAnsiChar);
Procedure Assign(out f:File;const c: AnsiChar);
Procedure Rename(var f:File;const s : ShortString);
Procedure Rename(var f:File;const p : PAnsiChar);
Procedure Rename(var f:File;const c : AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:File;const Name: UnicodeString);
Procedure Rename(var f:File;const s : UnicodeString);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:File;const Name: RawByteString);
Procedure Rename(var f:File;const s : RawByteString);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rewrite(var f:File;l:Longint);
Procedure Rewrite(var f:File);
Procedure Reset(var f:File;l:Longint);
@ -539,9 +559,6 @@ Function FileSize(var f:File):Int64;
Procedure Seek(var f:File;Pos:Int64);
Function EOF(var f:File):Boolean;
Procedure Erase(var f:File);
Procedure Rename(var f:File;const s:string);
Procedure Rename(var f:File;p:pchar);
Procedure Rename(var f:File;c:char);
Procedure Truncate (var F:File);
{$endif FPC_HAS_FEATURE_FILEIO}
@ -551,9 +568,15 @@ Procedure Truncate (var F:File);
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure Assign(out f:TypedFile;const Name:string);
Procedure Assign(out f:TypedFile;p:pchar);
Procedure Assign(out f:TypedFile;c:char);
Procedure Assign(out f:TypedFile;const Name:shortstring);
Procedure Assign(out f:TypedFile;const p:PAnsiChar);
Procedure Assign(out f:TypedFile;const c:AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out f:TypedFile;const Name:unicodestring);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Assign(out f:TypedFile;const Name:rawbytestring);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Reset(var f : TypedFile); [INTERNPROC: fpc_in_Reset_TypedFile];
Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
{$endif FPC_HAS_FEATURE_FILEIO}
@ -563,18 +586,26 @@ Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile];
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_TEXTIO}
Procedure Assign(out t:Text;const s:string);
Procedure Assign(out t:Text;p:pchar);
Procedure Assign(out t:Text;c:char);
Procedure Assign(out t:Text;const s:shortstring);
Procedure Rename(var t:Text;const s:shortstring);
Procedure Assign(out t:Text;const p:PAnsiChar);
Procedure Rename(var t:Text;const p:PAnsiChar);
Procedure Assign(out t:Text;const c:AnsiChar);
Procedure Rename(var t:Text;const c:AnsiChar);
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure Assign(out t:Text;const s:unicodestring);
Procedure Rename(var t:Text;const s:unicodestring);
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Rename(var t:Text;const s:rawbytestring);
Procedure Assign(out t:Text;const s:rawbytestring);
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
Procedure Close(var t:Text);
Procedure Rewrite(var t:Text);
Procedure Reset(var t:Text);
Procedure Append(var t:Text);
Procedure Flush(var t:Text);
Procedure Erase(var t:Text);
Procedure Rename(var t:Text;const s:string);
Procedure Rename(var t:Text;p:pchar);
Procedure Rename(var t:Text;c:char);
Function EOF(var t:Text):Boolean;
Function EOF:Boolean;
Function EOLn(var t:Text):Boolean;
@ -594,19 +625,29 @@ procedure SetTextCodePage(var T: Text; CodePage: TSystemCodePage);
Directory Management
****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
Procedure chdir(const s:string); overload;
Procedure mkdir(const s:string); overload;
Procedure rmdir(const s:string); overload;
// the pchar versions are exported via alias for use in objpas
Procedure getdir(drivenr:byte;var dir:shortstring);
Procedure chdir(const s:shortstring); overload;
Procedure mkdir(const s:shortstring); overload;
Procedure rmdir(const s:shortstring); overload;
Procedure getdir(drivenr:byte;var dir:shortstring);overload;
{$ifdef FPC_HAS_FEATURE_ANSISTRINGS}
Procedure getdir(drivenr:byte;var dir:ansistring);
Procedure chdir(const s:rawbytestring); overload;
Procedure mkdir(const s:rawbytestring); overload;
Procedure rmdir(const s:rawbytestring); overload;
// defaultrtlfilesystemcodepage is returned here
Procedure getdir(drivenr:byte;var dir: rawbytestring);overload;{$ifdef FPC_HAS_CPSTRING}rtlproc;{$endif FPC_HAS_CPSTRING}
{$endif FPC_HAS_FEATURE_ANSISTRINGS}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
Procedure chdir(const s:unicodestring); overload;
Procedure mkdir(const s:unicodestring); overload;
Procedure rmdir(const s:unicodestring); overload;
Procedure getdir(drivenr:byte;var dir: unicodestring);overload;
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
{$endif FPC_HAS_FEATURE_FILEIO}
{*****************************************************************************
Miscellaneous
*****************************************************************************}
@ -624,14 +665,17 @@ function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;[INTERNPROC:
function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif}
{$ENDIF}
Function Get_pc_addr : Pointer;
Function Get_pc_addr : CodePointer;
(*
procedure get_caller_stackinfo(var framebp,addr : pointer);
function get_caller_addr(framebp:pointer;addr:pointer=nil):pointer;
function get_caller_frame(framebp:pointer;addr:pointer=nil):pointer;
*)
{ Writes at most 'count' caller stack frames to pre-allocated buffer pointed to
by 'frames', skipping 'skipframes' initial frames. Returns number of frames written. }
function CaptureBacktrace(skipframes,count:sizeint;frames:PCodePointer):sizeint;
function get_caller_addr(framebp:pointer;addr:codepointer=nil):codepointer;
function get_caller_frame(framebp:pointer;addr:codepointer=nil):pointer;
procedure get_caller_stackinfo(var framebp : pointer; var addr : codepointer);
*)
//Function IOResult:Word;
//Function Sptr:Pointer;[internconst:fpc_in_const_ptr];
@ -760,7 +804,8 @@ Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar;
(*
procedure AbstractError;external name 'FPC_ABSTRACTERROR';
Function SysBackTraceStr(Addr:Pointer): ShortString;
procedure EmptyMethod;external name 'FPC_EMPTYMETHOD';
Function SysBackTraceStr(Addr:CodePointer): ShortString;
Procedure SysAssert(const Msg,FName:ShortString;LineNo:Longint;ErrorAddr:Pointer);
*)
(* Supposed to return address of previous CtrlBreakHandler *)
@ -773,14 +818,15 @@ function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler;
{ Error handlers }
Type
(*
TBackTraceStrFunc = Function (Addr: Pointer): ShortString;
TBackTraceStrFunc = Function (Addr: CodePointer): ShortString;
*)
TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer);
TErrorProc = Procedure (ErrNo : Longint; Address : CodePointer; Frame : Pointer);
(*
TAbstractErrorProc = Procedure;
TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer);
TSafeCallErrorProc = Procedure(error : HResult;addr : pointer);
*)
const
(*
BackTraceStrFunc : TBackTraceStrFunc = @SysBackTraceStr;

194
rtl/java/jsystemh_types.inc
View File

@ -30,10 +30,10 @@
{$inline on}
{$define SYSTEMINLINE}
{ don't use FPU registervariables on the i386 }
{$ifdef CPUI386}
{ don't use FPU registervariables on the i386 and i8086 }
{$if defined(CPUI386) or defined(CPUI8086)}
{$maxfpuregisters 0}
{$endif CPUI386}
{$endif CPUI386 or CPUI8086}
{ the assembler helpers need this}
{$ifdef CPUPOWERPC}
@ -60,6 +60,17 @@
Global Types and Constants
****************************************************************************}
{ some values which are used in RTL for TSystemCodePage type }
const
CP_ACP = 0; // default to ANSI code page
CP_OEMCP = 1; // default to OEM (console) code page
CP_UTF16 = 1200; // utf-16
CP_UTF16BE = 1201; // unicodeFFFE
CP_UTF7 = 65000; // utf-7
CP_UTF8 = 65001; // utf-8
CP_ASCII = 20127; // us-ascii
CP_NONE = $FFFF; // rawbytestring encoding
Type
{ The compiler has all integer types defined internally. Here
we define only aliases }
@ -75,6 +86,9 @@ Type
Real = type Double;
{$endif}
{ Can be individually defined/undefined on a per-platform basis }
{ define FLOAT_ASCII_FALLBACK}
{$ifdef CPUI386}
{$define CPU32}
@ -88,8 +102,49 @@ Type
{$ifndef FPUNONE}
ValReal = Extended;
{$endif}
{$ifndef VER2_6}
FarPointer = NearFsPointer;
{$endif}
{$endif CPUI386}
{$ifdef CPUI8086}
{$define CPU16}
{$define DEFAULT_EXTENDED}
{$define SUPPORT_SINGLE}
{$define SUPPORT_DOUBLE}
{$define SUPPORT_EXTENDED}
{$define SUPPORT_COMP}
{$ifndef FPUNONE}
ValReal = Extended;
{$endif}
{$if defined(FPC_MM_TINY)}
{$define FPC_X86_CODE_NEAR}
{$define FPC_X86_DATA_NEAR}
{$elseif defined(FPC_MM_SMALL)}
{$define FPC_X86_CODE_NEAR}
{$define FPC_X86_DATA_NEAR}
{$elseif defined(FPC_MM_MEDIUM)}
{$define FPC_X86_CODE_FAR}
{$define FPC_X86_DATA_NEAR}
{$elseif defined(FPC_MM_COMPACT)}
{$define FPC_X86_CODE_NEAR}
{$define FPC_X86_DATA_FAR}
{$elseif defined(FPC_MM_LARGE)}
{$define FPC_X86_CODE_FAR}
{$define FPC_X86_DATA_FAR}
{$elseif defined(FPC_MM_HUGE)}
{$define FPC_X86_CODE_FAR}
{$define FPC_X86_DATA_HUGE}
{$else}
{$fatal No memory model defined}
{$endif}
{$endif CPUI8086}
{$ifdef CPUX86_64}
{$ifdef FPC_HAS_TYPE_EXTENDED}
{ win64 doesn't support the legacy fpu }
@ -113,11 +168,22 @@ Type
{$define SUPPORT_SINGLE}
{$define SUPPORT_DOUBLE}
{$ifndef VER2_6}
FarPointer = Pointer;
{$endif}
{$endif CPUX86_64}
{$ifdef CPUM68K}
{$define DEFAULT_DOUBLE}
{$ifdef FPUSOFT}
{$define FPC_INCLUDE_SOFTWARE_MOD_DIV}
{$define FPC_INCLUDE_SOFTWARE_MUL}
{$endif}
{ m68k int64 shl/shr uses soft helper for non constaznt values }
{$define FPC_INCLUDE_SOFTWARE_SHIFT_INT64}
{$define SUPPORT_SINGLE}
{$define SUPPORT_DOUBLE}
@ -170,7 +236,7 @@ Type
FarPointer = Pointer;
{$endif CPUSPARC}
{$ifdef CPUMIPS32}
{$if defined(CPUMIPS32) or defined(CPUMIPSEL32)}
{$define DEFAULT_DOUBLE}
{$define SUPPORT_SINGLE}
@ -255,6 +321,9 @@ Type
PtrUInt = QWord;
ValSInt = int64;
ValUInt = qword;
CodePointer = Pointer;
CodePtrInt = PtrInt;
CodePtrUInt = PtrUInt;
{$endif CPU64}
{$ifdef CPU32}
@ -264,19 +333,47 @@ Type
PtrUInt = DWord;
ValSInt = Longint;
ValUInt = Cardinal;
CodePointer = Pointer;
CodePtrInt = PtrInt;
CodePtrUInt = PtrUInt;
{$endif CPU32}
{$ifdef CPU16}
SizeInt = Integer;
SizeUInt = Word;
PtrInt = Integer;
PtrUInt = Word;
{$if defined(FPC_X86_DATA_FAR) or defined(FPC_X86_DATA_HUGE)}
PtrInt = Longint;
PtrUInt = DWord;
{$else}
PtrInt = Integer;
PtrUInt = Word;
{$endif}
{$if defined(FPC_X86_CODE_FAR)}
CodePointer = FarPointer;
CodePtrInt = Longint;
CodePtrUInt = DWord;
{$elseif defined(FPC_X86_CODE_NEAR)}
CodePointer = NearPointer;
CodePtrInt = Integer;
CodePtrUInt = Word;
{$else}
CodePointer = Pointer;
CodePtrInt = PtrInt;
CodePtrUInt = PtrUInt;
{$endif}
ValSInt = Integer;
ValUInt = Word;
{$endif CPU16}
{ NativeInt and NativeUInt are Delphi compatibility types. Even though Delphi
has IntPtr and UIntPtr, the Delphi documentation for NativeInt states that
'The size of NativeInt is equivalent to the size of the pointer on the
current platform'. Because of the misleading names, these types shouldn't be
used in the FPC RTL. Note that on i8086 their size changes between 16-bit
and 32-bit according to the memory model, so they're not really a 'native
int' type there at all. }
NativeInt = PtrInt;
NativeUint = PtrUint;
NativeUInt = PtrUInt;
Int8 = ShortInt;
Int16 = SmallInt;
@ -292,18 +389,6 @@ Type
PPChar = ^PChar;
PPPChar = ^PPChar;
{ some values which are used in RTL for TSystemCodePage type }
const
CP_ACP = 0; // default to ANSI code page
CP_OEMCP = 1; // default to OEM (console) code page
CP_UTF16 = 1200; // utf-16
CP_UTF16BE = 1201; // unicodeFFFE
CP_UTF7 = 65000; // utf-7
CP_UTF8 = 65001; // utf-8
CP_ASCII = 20127; // us-ascii
CP_NONE = $FFFF; // rawbytestring encoding
type
{ AnsiChar is equivalent of Char, so we need
to use type renamings }
TAnsiChar = Char;
@ -353,6 +438,7 @@ type
{$ifdef SUPPORT_COMP}
PComp = ^Comp;
{$endif SUPPORT_COMP}
PSmallInt = ^Smallint;
PShortInt = ^Shortint;
PInteger = ^Integer;
@ -374,15 +460,30 @@ type
PPointer = ^Pointer;
PPPointer = ^PPointer;
PCodePointer = ^CodePointer;
PPCodePointer = ^PCodePointer;
PBoolean = ^Boolean;
PWordBool = ^WordBool;
PLongBool = ^LongBool;
PNativeInt = ^NativeInt;
PNativeUInt = ^NativeUint;
pInt8 = PShortInt;
pInt16 = PSmallint;
pInt32 = PLongint;
PIntPtr = PPtrInt;
pUInt8 = PByte;
pUInt16 = PWord;
pUInt32 = PDWord;
PUintPtr = PPtrUInt;
PShortString = ^ShortString;
PAnsiString = ^AnsiString;
{$ifndef FPUNONE}
PDate = ^TDateTime;
PDateTime = ^TDateTime;
PDateTime = ^TDateTime;
{$endif}
PError = ^TError;
PVariant = ^Variant;
@ -402,21 +503,39 @@ type
TSystemCodePage = Word;
(*
{ Needed for fpc_get_output }
PText = ^Text;
*)
{$ifdef VER2_6}
{ the size of textrec/filerec is hardcoded in the 2.6 compiler binary }
{$define FPC_ANSI_TEXTFILEREC}
{$endif}
TFileTextRecChar = {$ifdef FPC_ANSI_TEXTFILEREC}AnsiChar{$else}UnicodeChar{$endif};
PFileTextRecChar = ^TFileTextRecChar;
TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR);
{ procedure type }
TProcedure = Procedure;
{ platform dependent types }
{ platform-dependent types }
{$i sysosh.inc}
{ platform-dependent defines }
{$i rtldefs.inc}
(*
{*****************************************************************************
TextRec/FileRec exported to allow compiler to take size
*****************************************************************************}
{$ifdef FPC_HAS_FEATURE_FILEIO}
{$i filerec.inc}
{$endif FPC_HAS_FEATURE_FILEIO}
{$i textrec.inc}
type
{ Needed for fpc_get_output }
PText = ^Text;
TEntryInformation = record
InitFinalTable : Pointer;
ThreadvarTablesTable : Pointer;
@ -478,8 +597,21 @@ const
Test8087 : byte = 3;
{ will be detected at startup }
has_sse_support : boolean = false;
has_sse2_support : boolean = false;
has_sse3_support : boolean = false;
has_mmx_support : boolean = false;
{$endif cpui386}
{$ifdef cpui8086}
{ will be detected at startup }
{ 0=8086/8088/80186/80188/NEC V20/NEC V30, 1=80286, 2=80386 or newer }
Test8086 : byte = 0; public name '__Test8086';
{ will be detected at startup }
{ 0=NO FPU, 1=8087, 2=80287, 3=80387 or newer }
Test8087 : byte = 0;
{ will be detected at startup }
has_sse_support : boolean = false;
has_mmx_support : boolean = false;
{$endif cpui8086}
{$ifdef cpum68k}
Test68000 : byte = 0; { Must be determined at startup for both }
Test68881 : byte = 0;
@ -489,8 +621,8 @@ const
Max_Frame_Dump : Word = 8;
(*
{ Exit Procedure handling consts and types }
ExitProc : pointer = nil;
Erroraddr: pointer = nil;
ExitProc : codepointer = nil;
Erroraddr: codepointer = nil;
*)
Errorcode: Word = 0;
@ -512,7 +644,7 @@ const
{ Indicates if there was an error }
StackError : boolean = FALSE;
(*
InitProc : Pointer = nil;
InitProc : CodePointer = nil;
*)
{ compatibility }
ModuleIsLib : Boolean = FALSE;
@ -523,6 +655,7 @@ var
ExitCode : Longint; (* public name 'operatingsystem_result'; *)
RandSeed : Cardinal;
{ Delphi compatibility }
{$ifdef FPC_HAS_FEATURE_DYNLIBS}
IsLibrary : boolean = false; public name 'operatingsystem_islibrary';
{$else FPC_HAS_FEATURE_DYNLIBS}
@ -531,7 +664,9 @@ const
var
{$endif FPC_HAS_FEATURE_DYNLIBS}
IsConsole : boolean = false; public name 'operatingsystem_isconsole';
NoErrMsg: Boolean platform = False; // For Delphi compatibility, not used in FPC.
FirstDotAtFileNameStartIsExtension : Boolean = False;
DefaultSystemCodePage,
DefaultUnicodeCodePage,
{ the code page to use when sending paths/file names to OS file system API
@ -566,7 +701,6 @@ Var
StdErr : Text;
InOutRes : Word;
{ Stack checking }
StackTop,
StackBottom : Pointer;
StackLength : SizeUInt;
*)