diff --git a/.gitattributes b/.gitattributes index 345b80e981..b2f7582f06 100644 --- a/.gitattributes +++ b/.gitattributes @@ -7361,24 +7361,36 @@ rtl/java/java_sys.inc svneol=native#text/plain rtl/java/java_sysh.inc svneol=native#text/plain rtl/java/jdk15.inc svneol=native#text/plain rtl/java/jdk15.pas svneol=native#text/plain +rtl/java/jdynarr.inc svneol=native#text/plain rtl/java/jdynarrh.inc svneol=native#text/plain -rtl/java/jint64.inc svneol=native#text/plain -rtl/java/jmath.inc svneol=native#text/plain rtl/java/jpvar.inc svneol=native#text/plain rtl/java/jpvarh.inc svneol=native#text/plain rtl/java/jrec.inc svneol=native#text/plain rtl/java/jrech.inc svneol=native#text/plain rtl/java/jset.inc svneol=native#text/plain rtl/java/jseth.inc svneol=native#text/plain +rtl/java/jsystem.inc svneol=native#text/plain +rtl/java/jsystemh.inc svneol=native#text/plain +rtl/java/jsystemh_types.inc svneol=native#text/plain +rtl/java/objpas.inc svneol=native#text/plain rtl/java/objpas.pp svneol=native#text/plain +rtl/java/objpash.inc svneol=native#text/plain rtl/java/rtl.cfg svneol=native#text/plain rtl/java/rtti.inc svneol=native#text/plain rtl/java/sstringh.inc svneol=native#text/plain rtl/java/sstrings.inc svneol=native#text/plain +rtl/java/sysos.inc svneol=native#text/plain +rtl/java/sysosh.inc svneol=native#text/plain +rtl/java/sysres.inc svneol=native#text/plain rtl/java/system.pp svneol=native#text/plain rtl/java/ustringh.inc svneol=native#text/plain rtl/java/ustrings.inc svneol=native#text/plain +rtl/jvm/int64p.inc svneol=native#text/plain +rtl/jvm/jvm.inc svneol=native#text/plain rtl/jvm/makefile.cpu svneol=native#text/plain +rtl/jvm/math.inc svneol=native#text/plain +rtl/jvm/setjump.inc svneol=native#text/plain +rtl/jvm/setjumph.inc svneol=native#text/plain rtl/linux/Makefile svneol=native#text/plain rtl/linux/Makefile.fpc svneol=native#text/plain rtl/linux/arm/bsyscall.inc svneol=native#text/plain diff --git a/compiler/options.pas b/compiler/options.pas index 33c175f3f2..92e196509e 100644 --- a/compiler/options.pas +++ b/compiler/options.pas @@ -2297,7 +2297,9 @@ begin // until these features are implemented, they are disabled in the compiler target_unsup_features:=[f_stackcheck]; system_jvm_java32: - target_unsup_features:=[f_threading,f_commandargs,f_fileio,f_textio,f_consoleio,f_dynlibs]; + target_unsup_features:=[f_heap,f_textio,f_consoleio,f_fileio, + f_variants,f_objects,f_threading,f_commandargs, + f_processes,f_stackcheck,f_dynlibs,f_softfpu,f_objectivec1,f_resources]; else target_unsup_features:=[]; end; @@ -2516,7 +2518,7 @@ begin def_system_macro('FPC_HAS_MEMBAR'); def_system_macro('FPC_SETBASE_USED'); -{$if defined(x86) or defined(arm)} +{$if defined(x86) or defined(arm) or defined(jvm)} def_system_macro('INTERNAL_BACKTRACE'); {$endif} def_system_macro('STR_CONCAT_PROCS'); diff --git a/compiler/systems/i_jvm.pas b/compiler/systems/i_jvm.pas index b66020cb5f..96ff6ca5b5 100644 --- a/compiler/systems/i_jvm.pas +++ b/compiler/systems/i_jvm.pas @@ -39,7 +39,7 @@ unit i_jvm; system : system_jvm_java32; name : 'Java Virtual Machine'; shortname : 'Java'; - flags : [tf_files_case_sensitive, + flags : [tf_files_case_sensitive,tf_no_generic_stackcheck, { avoid the creation of threadvar tables } tf_section_threadvars]; cpu : cpu_jvm; diff --git a/rtl/inc/currh.inc b/rtl/inc/currh.inc index aae57a12c8..2382b134f5 100644 --- a/rtl/inc/currh.inc +++ b/rtl/inc/currh.inc @@ -15,9 +15,14 @@ {$ifdef FPC_CURRENCY_IS_INT64} function trunc(c : currency) : int64; - function trunc(c : comp) : int64; function round(c : currency) : int64; +{$ifndef cpujvm} + function trunc(c : comp) : int64; function round(c : comp) : int64; +{$else not cpujvm} + function trunc_comp(c: comp) : int64; + function round_comp(c : comp) : int64; +{$endif not cpujvm} {$endif FPC_CURRENCY_IS_INT64} diff --git a/rtl/inc/gencurr.inc b/rtl/inc/gencurr.inc index 1fd5afd5cf..618b36486c 100644 --- a/rtl/inc/gencurr.inc +++ b/rtl/inc/gencurr.inc @@ -15,35 +15,31 @@ {$ifdef FPC_CURRENCY_IS_INT64} function trunc(c : currency) : int64; - type - tmyrec = record - i: int64; - end; begin - result := int64(tmyrec(c)) div 10000 + { the type conversion includes dividing by 10000 } + result := int64(c) end; - +{$ifndef cpujvm} function trunc(c : comp) : int64; +{$else not cpujvm} + function trunc_comp(c : comp) : int64; +{$endif cpujvm} begin result := c end; function round(c : currency) : int64; - type - tmyrec = record - i: int64; - end; var - rem, absrem: longint; + rem, absrem: currency; begin { (int64(tmyrec(c))(+/-)5000) div 10000 can overflow } - result := int64(tmyrec(c)) div 10000; - rem := int64(tmyrec(c)) - result * 10000; + result := int64(c); + rem := c - currency(result); absrem := abs(rem); - if (absrem > 5000) or - ((absrem = 5000) and + if (absrem > 0.5) or + ((absrem = 0.5) and (rem > 0)) then if (rem > 0) then inc(result) @@ -52,7 +48,11 @@ end; +{$ifndef cpujvm} function round(c : comp) : int64; +{$else not cpujvm} + function round_comp(c : comp) : int64; +{$endif cpujvm} begin result := c end; diff --git a/rtl/inc/generic.inc b/rtl/inc/generic.inc index 449bc24e70..0578407768 100644 --- a/rtl/inc/generic.inc +++ b/rtl/inc/generic.inc @@ -1120,6 +1120,7 @@ end; {$endif ndef FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} +{$ifndef JVM} {$ifndef FPC_STRTOSHORTSTRINGPROC} @@ -1142,6 +1143,8 @@ function strpas(p:pchar):shortstring;{$ifdef SYSTEMINLINE}inline;{$endif} {$endif FPC_STRTOSHORTSTRINGPROC} end; +{$endif not JVM} + {$ifndef FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} {$ifndef FPC_STRTOSHORTSTRINGPROC} @@ -1758,6 +1761,7 @@ function align(addr : PtrUInt;alignment : PtrUInt) : PtrUInt;{$ifdef SYSTEMINLIN end; +{$ifndef JVM} function align(addr : Pointer;alignment : PtrUInt) : Pointer;{$ifdef SYSTEMINLINE}inline;{$endif} var tmp: PtrUInt; @@ -1765,7 +1769,7 @@ function align(addr : Pointer;alignment : PtrUInt) : Pointer;{$ifdef SYSTEMINLIN tmp:=PtrUInt(addr)+alignment-1; result:=pointer(tmp-(tmp mod alignment)); end; - +{$endif} {**************************************************************************** Str() @@ -1773,7 +1777,7 @@ function align(addr : Pointer;alignment : PtrUInt) : Pointer;{$ifdef SYSTEMINLIN {$ifndef FPC_SYSTEM_HAS_INT_STR_LONGINT} -procedure int_str(l:longint;out s:string); +procedure int_str(l:longint;out s:shortstring); var m,m1 : longword; pcstart, @@ -1816,7 +1820,7 @@ end; {$ifndef FPC_SYSTEM_HAS_INT_STR_LONGWORD} -procedure int_str(l:longword;out s:string); +procedure int_str_unsigned(l:longword;out s:shortstring); var m1 : longword; pcstart, @@ -1851,7 +1855,7 @@ end; {$ifndef FPC_SYSTEM_HAS_INT_STR_INT64} -procedure int_str(l:int64;out s:string); +procedure int_str(l:int64;out s:shortstring); var m,m1 : qword; pcstart, @@ -1894,7 +1898,7 @@ end; {$ifndef FPC_SYSTEM_HAS_INT_STR_QWORD} -procedure int_str(l:qword;out s:string); +procedure int_str_unsigned(l:qword;out s:shortstring); var m1 : qword; pcstart, @@ -1957,12 +1961,12 @@ function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inlin Result := SmallInt((Word(AValue) shr 8) or (Word(AValue) shl 8)); end; - +{$ifndef cpujvm} function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} begin Result := Word((AValue shr 8) or (AValue shl 8)); end; - +{$endif} function SwapEndian(const AValue: LongInt): LongInt; begin @@ -1972,7 +1976,7 @@ function SwapEndian(const AValue: LongInt): LongInt; or (AValue shr 24); end; - +{$ifndef cpujvm} function SwapEndian(const AValue: DWord): DWord; begin Result := (AValue shl 24) @@ -1980,7 +1984,7 @@ function SwapEndian(const AValue: DWord): DWord; or ((AValue and $00FF0000) shr 8) or (AValue shr 24); end; - +{$endif} function SwapEndian(const AValue: Int64): Int64; begin @@ -1994,7 +1998,7 @@ function SwapEndian(const AValue: Int64): Int64; or (AValue shr 56); end; - +{$ifndef cpujvm} function SwapEndian(const AValue: QWord): QWord; begin Result := (AValue shl 56) @@ -2006,6 +2010,7 @@ function SwapEndian(const AValue: QWord): QWord; or ((AValue and $00FF000000000000) shr 40) or (AValue shr 56); end; +{$endif} {$endif FPC_SYSTEM_HAS_SWAPENDIAN} function BEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2018,6 +2023,7 @@ function BEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$e end; +{$ifndef cpujvm} function BEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2026,6 +2032,7 @@ function BEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function BEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2038,6 +2045,7 @@ function BEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$end end; +{$ifndef cpujvm} function BEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2046,6 +2054,7 @@ function BEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function BEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2058,6 +2067,7 @@ function BEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} end; +{$ifndef cpujvm} function BEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2066,6 +2076,7 @@ function BEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} @@ -2079,6 +2090,7 @@ function LEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$e end; +{$ifndef cpujvm} function LEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2087,6 +2099,7 @@ function LEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function LEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2099,6 +2112,7 @@ function LEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$end end; +{$ifndef cpujvm} function LEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2107,6 +2121,7 @@ function LEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function LEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2119,6 +2134,7 @@ function LEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} end; +{$ifndef cpujvm} function LEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2127,6 +2143,7 @@ function LEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} @@ -2140,6 +2157,7 @@ function NtoBE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$e end; +{$ifndef cpujvm} function NtoBE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2148,6 +2166,7 @@ function NtoBE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function NtoBE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2160,6 +2179,7 @@ function NtoBE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$end end; +{$ifndef cpujvm} function NtoBE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2168,6 +2188,7 @@ function NtoBE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function NtoBE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2180,6 +2201,7 @@ function NtoBE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} end; +{$ifndef cpujvm} function NtoBE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_BIG} @@ -2188,6 +2210,7 @@ function NtoBE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function NtoLE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2200,6 +2223,7 @@ function NtoLE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$e end; +{$ifndef cpujvm} function NtoLE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2208,6 +2232,7 @@ function NtoLE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function NtoLE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2220,6 +2245,7 @@ function NtoLE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$end end; +{$ifndef cpujvm} function NtoLE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2228,6 +2254,7 @@ function NtoLE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} function NtoLE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} @@ -2240,6 +2267,7 @@ function NtoLE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} end; +{$ifndef cpujvm} function NtoLE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} begin {$IFDEF ENDIAN_LITTLE} @@ -2248,6 +2276,7 @@ function NtoLE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} Result := SwapEndian(AValue); {$ENDIF} end; +{$endif not cpujvm} {$ifndef FPC_SYSTEM_HAS_MEM_BARRIER} diff --git a/rtl/inc/genmath.inc b/rtl/inc/genmath.inc index fd3d7c3dcf..97a8f6c5cd 100644 --- a/rtl/inc/genmath.inc +++ b/rtl/inc/genmath.inc @@ -946,6 +946,7 @@ invalid: Begin fr := abs(Frac(d)); tr := Trunc(d); + result:=0; case softfloat_rounding_mode of float_round_nearest_even: begin @@ -983,6 +984,9 @@ invalid: result:=tr; float_round_to_zero: result:=tr; + else + { needed for jvm: result must be initialized on all paths } + result:=0; end; end; {$endif FPC_SYSTEM_HAS_ROUND} diff --git a/rtl/inc/sstrings.inc b/rtl/inc/sstrings.inc index ae9cc4cd7e..fdb8c9ef54 100644 --- a/rtl/inc/sstrings.inc +++ b/rtl/inc/sstrings.inc @@ -15,13 +15,19 @@ subroutines for string handling ****************************************************************************} +{$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; begin if Len>255 then Len:=255; s[0]:=chr(len); end; +{$endif FPC_HAS_SHORTSTR_SETLENGTH} + +{$ifndef FPC_HAS_SHORTSTR_COPY} +{$define FPC_HAS_SHORTSTR_COPY} function fpc_shortstr_copy(const s : shortstring;index : SizeInt;count : SizeInt): shortstring;compilerproc; begin if count<0 then @@ -38,8 +44,11 @@ begin fpc_shortstr_Copy[0]:=chr(Count); Move(s[Index+1],fpc_shortstr_Copy[1],Count); end; +{$endif FPC_HAS_SHORTSTR_COPY} +{$ifndef FPC_HAS_SHORTSTR_DELETE} +{$define FPC_HAS_SHORTSTR_DELETE} procedure delete(var s : shortstring;index : SizeInt;count : SizeInt); begin if index<=0 then @@ -53,8 +62,11 @@ begin Move(s[Index+Count],s[Index],Length(s)-Index+1); end; end; +{$endif FPC_HAS_SHORTSTR_DELETE} +{$ifndef FPC_HAS_SHORTSTR_INSERT} +{$define FPC_HAS_SHORTSTR_INSERT} procedure insert(const source : shortstring;var s : shortstring;index : SizeInt); var cut,srclen,indexlen : SizeInt; @@ -80,8 +92,11 @@ begin move(Source[1],s[Index],srclen); s[0]:=chr(index+srclen+indexlen-1); end; +{$endif FPC_HAS_SHORTSTR_INSERT} +{$ifndef FPC_HAS_SHORTSTR_INSERT_CHAR} +{$define FPC_HAS_SHORTSTR_INSERT_CHAR} procedure insert(source : Char;var s : shortstring;index : SizeInt); var indexlen : SizeInt; @@ -97,8 +112,11 @@ begin s[Index]:=Source; s[0]:=chr(index+indexlen); end; +{$endif FPC_HAS_SHORTSTR_INSERT_CHAR} +{$ifndef FPC_HAS_SHORTSTR_POS_SHORTSTR} +{$define FPC_HAS_SHORTSTR_POS_SHORTSTR} function pos(const substr : shortstring;const s : shortstring):SizeInt; var i,MaxLen : SizeInt; @@ -123,8 +141,11 @@ begin end; end; end; +{$endif FPC_HAS_SHORTSTR_POS_SHORTSTR} +{$ifndef FPC_HAS_SHORTSTR_POS_CHAR} +{$define FPC_HAS_SHORTSTR_POS_CHAR} {Faster when looking for a single char...} function pos(c:char;const s:shortstring):SizeInt; var @@ -143,6 +164,7 @@ begin end; pos:=0; end; +{$endif FPC_HAS_SHORTSTR_POS_CHAR} function fpc_char_copy(c:char;index : SizeInt;count : SizeInt): shortstring;compilerproc; @@ -162,12 +184,16 @@ begin end; +{$if not defined(FPC_UPCASE_CHAR) or not defined(FPC_LOWERCASE_CHAR)} {$ifdef IBM_CHAR_SET} const UpCaseTbl : shortstring[7]=#154#142#153#144#128#143#165; LoCaseTbl : shortstring[7]=#129#132#148#130#135#134#164; {$endif} +{$endif} +{$ifndef FPC_UPCASE_CHAR} +{$define FPC_UPCASE_CHAR} function upcase(c : char) : char; {$IFDEF IBM_CHAR_SET} var @@ -189,8 +215,11 @@ begin upcase:=c; {$ENDIF} end; +{$endif FPC_UPCASE_CHAR} +{$ifndef FPC_UPCASE_SHORTSTR} +{$define FPC_UPCASE_SHORTSTR} function upcase(const s : shortstring) : shortstring; var i : longint; @@ -199,8 +228,11 @@ begin for i := 1 to length (s) do upcase[i] := upcase (s[i]); end; +{$endif FPC_UPCASE_SHORTSTR} +{$ifndef FPC_LOWERCASE_CHAR} +{$define FPC_LOWERCASE_CHAR} function lowercase(c : char) : char;overload; {$IFDEF IBM_CHAR_SET} var @@ -222,8 +254,11 @@ begin lowercase:=c; {$ENDIF} end; +{$endif FPC_LOWERCASE_CHAR} +{$ifndef FPC_LOWERCASE_SHORTSTR} +{$define FPC_LOWERCASE_SHORTSTR} function lowercase(const s : shortstring) : shortstring; overload; var i : longint; @@ -232,7 +267,7 @@ begin for i:=1 to length(s) do lowercase[i]:=lowercase (s[i]); end; - +{$endif FPC_LOWERCASE_SHORTSTR} const HexTbl : array[0..15] of char='0123456789ABCDEF'; @@ -367,7 +402,7 @@ end; procedure fpc_shortstr_UInt(v : valUInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_UINT']; compilerproc; begin - int_str(v,s); + int_str_unsigned(v,s); if length(s)=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { causes exception in JLSystem.arraycopy } + if (srccopylen=0) or + (dstlen=0) then + exit; + JLSystem.arraycopy(src,srcstart,dst,0,min(srccopylen,dstlen)); + end; + + +procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1); + var + i: longint; + srclen, dstlen: jint; + begin + srclen:=length(src); + dstlen:=length(dst); + if srcstart=-1 then + srcstart:=0 + else if srcstart>=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { no arraycopy, have to clone each element } + for i:=0 to min(srccopylen,dstlen)-1 do + src[srcstart+i].fpcDeepCopy(dst[i]); + end; + + +procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1); + var + i: longint; + srclen, dstlen: jint; + begin + srclen:=length(src); + dstlen:=length(dst); + if srcstart=-1 then + srcstart:=0 + else if srcstart>=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { no arraycopy, have to clone each element } + for i:=0 to min(srccopylen,dstlen)-1 do + begin + dst[i].clear; + dst[i].addAll(src[srcstart+i]); + end; + end; + + +procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1); + var + i: longint; + srclen, dstlen: jint; + begin + srclen:=length(src); + dstlen:=length(dst); + if srcstart=-1 then + srcstart:=0 + else if srcstart>=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { no arraycopy, have to clone each element } + for i:=0 to min(srccopylen,dstlen)-1 do + begin + dst[i].clear; + dst[i].addAll(src[srcstart+i]); + end; + end; + + +procedure fpc_copy_jprocvar_array(src, dst: TJProcVarArray; srcstart: jint = -1; srccopylen: jint = -1); + var + i: longint; + srclen, dstlen: jint; + begin + srclen:=length(src); + dstlen:=length(dst); + if srcstart=-1 then + srcstart:=0 + else if srcstart>=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { no arraycopy, have to clone each element } + for i:=0 to min(srccopylen,dstlen)-1 do + src[srcstart+i].fpcDeepCopy(dst[i]); + end; + + +procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1); + var + i: longint; + srclen, dstlen: jint; + begin + srclen:=length(src); + dstlen:=length(dst); + if srcstart=-1 then + srcstart:=0 + else if srcstart>=srclen then + exit; + if srccopylen=-1 then + srccopylen:=srclen + else if srcstart+srccopylen>srclen then + srccopylen:=srclen-srcstart; + { no arraycopy, have to clone each element } + for i:=0 to min(srccopylen,dstlen)-1 do + pshortstring(src[srcstart+i])^:=pshortstring(dst[i])^; + end; + + +{ 1-dimensional setlength routines } + +function fpc_setlength_dynarr_generic(aorg, anew: JLObject; deepcopy: boolean; docopy: boolean = true): JLObject; + var + orglen, newlen: jint; + begin + orglen:=0; + newlen:=0; + if not deepcopy then + begin + if assigned(aorg) then + orglen:=JLRArray.getLength(aorg) + else + orglen:=0; + if assigned(anew) then + newlen:=JLRArray.getLength(anew) + else + newlen:=0; + end; + if deepcopy or + (orglen<>newlen) then + begin + if docopy then + fpc_copy_shallow_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray; + begin + if deepcopy or + (length(aorg)<>length(anew)) then + begin + fpc_copy_jrecord_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +function fpc_setlength_dynarr_jenumset(aorg, anew: TJEnumSetArray; deepcopy: boolean): TJEnumSetArray; + begin + if deepcopy or + (length(aorg)<>length(anew)) then + begin + fpc_copy_jenumset_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +function fpc_setlength_dynarr_jbitset(aorg, anew: TJBitSetArray; deepcopy: boolean): TJBitSetArray; + begin + if deepcopy or + (length(aorg)<>length(anew)) then + begin + fpc_copy_jbitset_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +function fpc_setlength_dynarr_jprocvar(aorg, anew: TJProcVarArray; deepcopy: boolean): TJProcVarArray; + begin + if deepcopy or + (length(aorg)<>length(anew)) then + begin + fpc_copy_jprocvar_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray; + begin + if deepcopy or + (length(aorg)<>length(anew)) then + begin + fpc_copy_jshortstring_array(aorg,anew); + result:=anew + end + else + result:=aorg; + end; + + +{ multi-dimensional setlength routine } +function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: boolean; ndim: longint; eletype: jchar): TJObjectArray; + var + partdone, + i: longint; + + begin + { resize the current dimension; no need to copy the subarrays of the old + array, as the subarrays will be (re-)initialised immediately below } + { the srcstart/srccopylen always refers to the first dimension (since copy() + performs a shallow copy of a dynamic array } + result:=TJObjectArray(fpc_setlength_dynarr_generic(JLObject(aorg),JLObject(anew),deepcopy,false)); + { if aorg was empty, there's nothing else to do since result will now + contain anew, of which all other dimensions are already initialised + correctly since there are no aorg elements to copy } + if not assigned(aorg) and + not deepcopy then + exit; + partdone:=min(high(result),high(aorg)); + { ndim must be >=2 when this routine is called, since it has to return + an array of java.lang.Object! (arrays are also objects, but primitive + types are not) } + if ndim=2 then + begin + { final dimension -> copy the primitive arrays } + case eletype of + FPCJDynArrTypeRecord: + begin + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_jrecord(TJRecordArray(aorg[i]),TJRecordArray(anew[i]),deepcopy)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(anew[i]),deepcopy)); + end; + FPCJDynArrTypeEnumSet: + begin + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_jenumset(TJEnumSetArray(aorg[i]),TJEnumSetArray(anew[i]),deepcopy)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_jenumset(nil,TJEnumSetArray(anew[i]),deepcopy)); + end; + FPCJDynArrTypeBitSet: + begin + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_jbitset(TJBitSetArray(aorg[i]),TJBitSetArray(anew[i]),deepcopy)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_jbitset(nil,TJBitSetArray(anew[i]),deepcopy)); + end; + FPCJDynArrTypeProcVar: + begin + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(TJProcVarArray(aorg[i]),TJProcVarArray(anew[i]),deepcopy)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(nil,TJProcVarArray(anew[i]),deepcopy)); + end; + FPCJDynArrTypeShortstring: + begin + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(TShortstringArray(aorg[i]),TShortstringArray(anew[i]),deepcopy)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(nil,TShortstringArray(anew[i]),deepcopy)); + end; + else + begin + for i:=low(result) to partdone do + result[i]:=fpc_setlength_dynarr_generic(aorg[i],anew[i],deepcopy); + for i:=succ(partdone) to high(result) do + result[i]:=fpc_setlength_dynarr_generic(nil,anew[i],deepcopy); + end; + end; + end + else + begin + { recursively handle the next dimension } + for i:=low(result) to partdone do + result[i]:=JLObject(fpc_setlength_dynarr_multidim(TJObjectArray(aorg[i]),TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype)); + for i:=succ(partdone) to high(result) do + result[i]:=JLObject(fpc_setlength_dynarr_multidim(nil,TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype)); + end; + end; + + +function fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; eletype: jchar): JLObject; + var + i: longint; + srclen: longint; + begin + if not assigned(src) then + begin + result:=nil; + exit; + end; + srclen:=JLRArray.getLength(src); + if (start=-1) and + (len=-1) then + begin + len:=srclen; + start:=0; + end + else if (start+len>srclen) then + len:=srclen-start+1; + result:=JLRArray.newInstance(src.getClass.getComponentType,len); + if ndim=1 then + begin + case eletype of + FPCJDynArrTypeRecord: + fpc_copy_jrecord_array(TJRecordArray(src),TJRecordArray(result),start,len); + FPCJDynArrTypeEnumSet: + fpc_copy_jenumset_array(TJEnumSetArray(src),TJEnumSetArray(result),start,len); + FPCJDynArrTypeBitSet: + fpc_copy_jbitset_array(TJBitSetArray(src),TJBitSetArray(result),start,len); + FPCJDynArrTypeProcvar: + fpc_copy_jprocvar_array(TJProcVarArray(src),TJProcVarArray(result),start,len); + FPCJDynArrTypeShortstring: + fpc_copy_jshortstring_array(TShortstringArray(src),TShortstringArray(result),start,len); + else + fpc_copy_shallow_array(src,result,start,len); + end + end + else + begin + for i:=0 to len-1 do + TJObjectArray(result)[i]:=fpc_dynarray_copy(TJObjectArray(src)[start+i],-1,-1,ndim-1,eletype); + end; + end; + diff --git a/rtl/java/jsystem.inc b/rtl/java/jsystem.inc new file mode 100644 index 0000000000..d3af69bce7 --- /dev/null +++ b/rtl/java/jsystem.inc @@ -0,0 +1,1491 @@ +{ + + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2008 by the Free Pascal development team + + See the file COPYING.FPC, included in this distribution, + For details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{ The RTTI is implemented through a series of constants : } + +Const + // please update tkManagedTypes below if you add new + // values + tkUnknown = 0; + tkInteger = 1; + tkChar = 2; + tkEnumeration = 3; + tkFloat = 4; + tkSet = 5; + tkMethod = 6; + tkSString = 7; + tkString = tkSString; + tkLString = 8; + tkAString = 9; + tkWString = 10; + tkVariant = 11; + tkArray = 12; + tkRecord = 13; + tkInterface = 14; + tkClass = 15; + tkObject = 16; + tkWChar = 17; + tkBool = 18; + tkInt64 = 19; + tkQWord = 20; + tkDynArray = 21; + tkInterfaceCorba = 22; + tkProcVar = 23; + tkUString = 24; + tkHelper = 26; + + // all potentially managed types + tkManagedTypes = [tkAstring,tkWstring,tkUstring,tkArray, + tkObject,tkRecord,tkDynArray,tkInterface,tkVariant]; + +{**************************************************************************** + Local types +****************************************************************************} + +{ + TextRec and FileRec are put in a separate file to make it available to other + units without putting it explicitly in systemh. + This way we keep TP compatibility, and the TextRec definition is available + for everyone who needs it. +} +{$ifdef FPC_HAS_FEATURE_FILEIO} +{$i filerec.inc} +{$endif FPC_HAS_FEATURE_FILEIO} + +{$ifdef FPC_HAS_FEATURE_TEXTIO} +{$i textrec.inc} +{$endif FPC_HAS_FEATURE_TEXTIO} + +{$ifdef FPC_HAS_FEATURE_EXITCODE} + {$ifdef FPC_OBJFPC_EXTENDED_IF} + {$if High(errorcode)<>maxExitCode} + {$define FPC_LIMITED_EXITCODE} + {$endif} + {$else} + {$define FPC_LIMITED_EXITCODE} + {$endif FPC_OBJFPC_EXTENDED_IF} +{$endif FPC_HAS_FEATURE_EXITCODE} + +Procedure HandleError (Errno : Longint); forward; +Procedure HandleErrorFrame (Errno : longint;frame : Pointer); forward; + +{$ifdef FPC_HAS_FEATURE_TEXTIO} +type + FileFunc = Procedure(var t : TextRec); +{$endif FPC_HAS_FEATURE_TEXTIO} + + +const + STACK_MARGIN = 16384; { Stack size margin for stack checking } +{ Random / Randomize constants } + OldRandSeed : Cardinal = 0; + +(* +{ For Error Handling.} + ErrorBase : Pointer = nil; +*) + +{ Used by the ansi/widestrings and maybe also other things in the future } +var + { widechar, because also used by widestring -> pwidechar conversions } + emptychar : widechar;public name 'FPC_EMPTYCHAR'; +{$ifndef FPC_NO_GENERIC_STACK_CHECK} + { if the OS does the stack checking, we don't need any stklen from the + main program } + initialstklen : SizeUint;external name '__stklen'; +{$endif FPC_NO_GENERIC_STACK_CHECK} + +{ checks whether the given suggested size for the stack of the current + thread is acceptable. If this is the case, returns it unaltered. + Otherwise it should return an acceptable value. + + Operating systems that automatically expand their stack on demand, should + simply return a very large value. + Operating systems which do not have a possibility to retrieve stack size + information, should simply return the given stklen value (This is the default + implementation). +} +{$ifdef FPC_HAS_FEATURE_STACKCHECK} +function CheckInitialStkLen(stklen : SizeUInt) : SizeUInt; forward; +{$endif FPC_HAS_FEATURE_STACKCHECK} + +{***************************************************************************** + OS dependent Helpers/Syscalls +*****************************************************************************} + +{ for some OSes do_isdevice is defined in sysos.inc, but for others (win32) + it isn't, and is used before the actual definition is encountered } + +{$ifdef FPC_HAS_FEATURE_FILEIO} +function do_isdevice(handle:thandle):boolean;forward; +{$endif FPC_HAS_FEATURE_FILEIO} + + +{$i sysos.inc} + + +{**************************************************************************** + Include processor specific routines +****************************************************************************} + +{$ifdef FPC_USE_LIBC} +{ Under Haiku, bcopy cause a problem when searching for include file + in the compiler. So, we use the internal implementation for now + under BeOS and Haiku. } +{$ifndef BEOS} +{ prefer libc implementations over our own, as they're most likely faster } +{$i cgeneric.inc} +{ is now declared as external reference to another routine in the interface } +{$i cgenstr.inc} +{$endif} +{$endif FPC_USE_LIBC} + +{$ifdef cpui386} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i i386.inc} { Case dependent, don't change } +{$endif cpui386} + +{$ifdef cpum68k} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i m68k.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpum68k} + +{$ifdef cpux86_64} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i x86_64.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpux86_64} + +{$ifdef cpupowerpc32} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i powerpc.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpupowerpc32} + +{$ifdef cpupowerpc64} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i powerpc64.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpupowerpc64} + +{$ifdef cpualpha} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i alpha.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpualpha} + +{$ifdef cpuiA64} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i ia64.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpuiA64} + +{$ifdef cpusparc} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i sparc.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpusparc} + +{$ifdef cpuarm} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$if defined(CPUCORTEXM3) or defined(CPUARMV7M)} + {$i thumb2.inc} { Case dependent, don't change } + {$else} + {$i arm.inc} { Case dependent, don't change } + {$endif} + {$define SYSPROCDEFINED} +{$endif cpuarm} + +{$ifdef cpuavr} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i avr.inc} { Case dependent, don't change } + {$define SYSPROCDEFINED} +{$endif cpuavr} + +{$ifdef cpujvm} + {$ifdef SYSPROCDEFINED} + {$Error Can't determine processor type !} + {$endif} + {$i jvm.inc} + {$define SYSPROCDEFINED} +{$endif cpuavr} + +{$ifndef jvm} +procedure fillchar(var x;count : SizeInt;value : boolean); +begin + fillchar(x,count,byte(value)); +end; + + +procedure fillchar(var x;count : SizeInt;value : char); +begin + fillchar(x,count,byte(value)); +end; + + +procedure FillByte (var x;count : SizeInt;value : byte ); +begin + FillChar (X,Count,VALUE); +end; + + +function IndexChar(Const buf;len:SizeInt;b:char):SizeInt; +begin + IndexChar:=IndexByte(Buf,Len,byte(B)); +end; + + +function CompareChar(Const buf1,buf2;len:SizeInt):SizeInt; +begin + CompareChar:=CompareByte(buf1,buf2,len); +end; +{$endif jvm} + +{ Include generic pascal only routines which are not defined in the processor + specific include file } +{$I generic.inc} + + +{**************************************************************************** + Set Handling +****************************************************************************} + +{$ifndef jvm} +{ Include set support which is processor specific} +{$i set.inc} +{ Include generic pascal routines for sets if the processor } +{ specific routines are not available. } +{$i genset.inc} +{$endif} + +{**************************************************************************** + Math Routines +****************************************************************************} + +function Hi(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif} +begin + Hi := b shr 4 +end; + +function Lo(b : byte): byte;{$ifdef SYSTEMINLINE}inline;{$endif} +begin + Lo := b and $0f +end; + +Function Swap (X : Word) : Word;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Swap := SwapEndian(X); +End; + +//Function Swap (X : Integer) : Integer;{$ifdef SYSTEMINLINE}inline;{$endif} +//Begin +// Swap := SwapEndian(X); +//End; + +Function Swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Swap:=(X and $ffff) shl 16 + (X shr 16) +End; + +//Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +//Begin +// Swap:=(X and $ffff) shl 16 + (X shr 16) +//End; + +//Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif} +//Begin +// Swap:=(X and $ffffffff) shl 32 + (X shr 32); +//End; + +Function swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Swap:=(X and $ffffffff) shl 32 + (X shr 32); +End; + +{$ifdef SUPPORT_DOUBLE} +operator := (b:real48) d:double;{$ifdef SYSTEMINLINE}inline;{$endif} +begin + D:=real2double(b); +end; +{$endif SUPPORT_DOUBLE} + +{$ifdef SUPPORT_EXTENDED} +operator := (b:real48) e:extended;{$ifdef SYSTEMINLINE}inline;{$endif} +begin + e:=real2double(b); +end; +{$endif SUPPORT_EXTENDED} + +{$ifndef FPUNONE} +{$ifdef FPC_USE_LIBC} +{ Include libc versions } +{$i cgenmath.inc} +{$endif FPC_USE_LIBC} +{ Include processor specific routines } +{$I math.inc} +{ Include generic version } +{$I genmath.inc} +{$endif} + +{$i gencurr.inc} + + +function aligntoptr(p : pointer) : pointer;inline; + begin +{$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} + result:=align(p,sizeof(p)); +{$else FPC_REQUIRES_PROPER_ALIGNMENT} + result:=p; +{$endif FPC_REQUIRES_PROPER_ALIGNMENT} + end; + + +{**************************************************************************** + Subroutines for String handling +****************************************************************************} + +{ Needs to be before RTTI handling } + +{$i sstrings.inc} + +{ requires sstrings.inc for initval } +{$I int64p.inc} +{ contains invalid typecasts for the JVM} +{$ifndef jvm} +{$I int64.inc} +{$endif not jvm} + +{Requires int64.inc, since that contains the VAL functions for int64 and qword} +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +{$i astrings.inc} +{$endif FPC_HAS_FEATURE_ANSISTRINGS} + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} + {$i wstrings.inc} + {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} + {$i ustrings.inc} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$i aliases.inc} + +{***************************************************************************** + Dynamic Array support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_DYNARRAYS} +(* +{$i dynarr.inc} +*) +{$endif FPC_HAS_FEATURE_DYNARRAYS} + +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_CLASSES} +{$i objpas.inc} +{$endif FPC_HAS_FEATURE_CLASSES} + +{***************************************************************************** + Variant support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_VARIANTS} +{$i variant.inc} +{$endif FPC_HAS_FEATURE_VARIANTS} + +{**************************************************************************** + Run-Time Type Information (RTTI) +****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_RTTI} +{$i rtti.inc} +{$endif FPC_HAS_FEATURE_RTTI} + +{$if defined(FPC_HAS_FEATURE_RANDOM)} + +{---------------------------------------------------------------------- + Mersenne Twister: A 623-Dimensionally Equidistributed Uniform + Pseudo-Random Number Generator. + + What is Mersenne Twister? + Mersenne Twister(MT) is a pseudorandom number generator developped by + Makoto Matsumoto and Takuji Nishimura (alphabetical order) during + 1996-1997. MT has the following merits: + It is designed with consideration on the flaws of various existing + generators. + Far longer period and far higher order of equidistribution than any + other implemented generators. (It is proved that the period is 2^19937-1, + and 623-dimensional equidistribution property is assured.) + Fast generation. (Although it depends on the system, it is reported that + MT is sometimes faster than the standard ANSI-C library in a system + with pipeline and cache memory.) + Efficient use of the memory. (The implemented C-code mt19937.c + consumes only 624 words of working area.) + + home page + http://www.math.keio.ac.jp/~matumoto/emt.html + original c source + http://www.math.keio.ac.jp/~nisimura/random/int/mt19937int.c + + Coded by Takuji Nishimura, considering the suggestions by + Topher Cooper and Marc Rieffel in July-Aug. 1997. + + This library is free software; you can redistribute it and/or + modify it under the terms of the GNU Library General Public + License as published by the Free Software Foundation; either + version 2 of the License, or (at your option) any later + version. + This library is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + See the GNU Library General Public License for more details. + You should have received a copy of the GNU Library General + Public License along with this library; if not, write to the + Free Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA + 02111-1307 USA + + Copyright (C) 1997, 1999 Makoto Matsumoto and Takuji Nishimura. + When you use this, send an email to: matumoto@math.keio.ac.jp + with an appropriate reference to your work. + + REFERENCE + M. Matsumoto and T. Nishimura, + "Mersenne Twister: A 623-Dimensionally Equidistributed Uniform + Pseudo-Random Number Generator", + ACM Transactions on Modeling and Computer Simulation, + Vol. 8, No. 1, January 1998, pp 3--30. + + + Translated to OP and Delphi interface added by Roman Krejci (6.12.1999) + + http://www.rksolution.cz/delphi/tips.htm + + Revised 21.6.2000: Bug in the function RandInt_MT19937 fixed + + 2003/10/26: adapted to use the improved intialisation mentioned at + and + removed the assembler code + + ----------------------------------------------------------------------} + +{$R-} {range checking off} +{$Q-} {overflow checking off} + +{ Period parameter } +Const + MT19937N=624; + +Type + tMT19937StateArray = array [0..MT19937N-1] of longint; // the array for the state vector + +{ Period parameters } +const + MT19937M=397; + MT19937MATRIX_A =$9908b0df; // constant vector a + MT19937UPPER_MASK=longint($80000000); // most significant w-r bits + MT19937LOWER_MASK=longint($7fffffff); // least significant r bits + +{ Tempering parameters } + TEMPERING_MASK_B=longint($9d2c5680); + TEMPERING_MASK_C=longint($efc60000); + + +VAR + mt : tMT19937StateArray; + +const + mti: longint=MT19937N+1; // mti=MT19937N+1 means mt[] is not initialized + +{ Initializing the array with a seed } +procedure sgenrand_MT19937(seed: longint); +var + i: longint; +begin + mt[0] := seed; + for i := 1 to MT19937N-1 do + begin + mt[i] := 1812433253 * (mt[i-1] xor (mt[i-1] shr 30)) + i; + { See Knuth TAOCP Vol2. 3rd Ed. P.106 for multiplier. } + { In the previous versions, MSBs of the seed affect } + { only MSBs of the array mt[]. } + { 2002/01/09 modified by Makoto Matsumoto } + end; + mti := MT19937N; +end; + + +function genrand_MT19937: longint; +const + mag01 : array [0..1] of longint =(0, longint(MT19937MATRIX_A)); +var + y: longint; + kk: longint; +begin + if RandSeed<>OldRandSeed then + mti:=MT19937N+1; + if (mti >= MT19937N) { generate MT19937N longints at one time } + then begin + if mti = (MT19937N+1) then // if sgenrand_MT19937() has not been called, + begin + sgenrand_MT19937(randseed); // default initial seed is used + { hack: randseed is not used more than once in this algorithm. Most } + { user changes are re-initialising reandseed with the value it had } + { at the start -> with the "not", we will detect this change. } + { Detecting other changes is not useful, since the generated } + { numbers will be different anyway. } + randseed := not(randseed); + oldrandseed := randseed; + end; + for kk:=0 to MT19937N-MT19937M-1 do begin + y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK); + mt[kk] := mt[kk+MT19937M] xor (y shr 1) xor mag01[y and $00000001]; + end; + for kk:= MT19937N-MT19937M to MT19937N-2 do begin + y := (mt[kk] and MT19937UPPER_MASK) or (mt[kk+1] and MT19937LOWER_MASK); + mt[kk] := mt[kk+(MT19937M-MT19937N)] xor (y shr 1) xor mag01[y and $00000001]; + end; + y := (mt[MT19937N-1] and MT19937UPPER_MASK) or (mt[0] and MT19937LOWER_MASK); + mt[MT19937N-1] := mt[MT19937M-1] xor (y shr 1) xor mag01[y and $00000001]; + mti := 0; + end; + y := mt[mti]; inc(mti); + y := y xor (y shr 11); + y := y xor (y shl 7) and TEMPERING_MASK_B; + y := y xor (y shl 15) and TEMPERING_MASK_C; + y := y xor (y shr 18); + Result := y; +end; + + +function random(l:longint): longint; +begin + { otherwise we can return values = l (JM) } + if (l < 0) then + inc(l); + random := longint((int64(cardinal(genrand_MT19937))*l) shr 32); +end; + +function random(l:int64): int64; +begin + { always call random, so the random generator cycles (TP-compatible) (JM) } + random := int64((qword(cardinal(genrand_MT19937)) or ((qword(cardinal(genrand_MT19937)) shl 32))) and $7fffffffffffffff); + if (l<>0) then + random := random mod l + else + random := 0; +end; + +{$ifndef FPUNONE} +function random: extended; +begin + random := cardinal(genrand_MT19937) * (extended(1.0)/(int64(1) shl 32)); +end; +{$endif} +{$endif FPC_HAS_FEATURE_RANDOM} + + +{**************************************************************************** + Memory Management +****************************************************************************} +(* +Function Ptr(sel,off : Longint) : farpointer;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + ptr:=farpointer((sel shl 4)+off); +End; + +Function CSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Cseg:=0; +End; + +Function DSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Dseg:=0; +End; + +Function SSeg : Word;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Sseg:=0; +End; +*) + + +{$ifopt R+} +{$define RangeCheckWasOn} +{$R-} +{$endif opt R+} + +{$ifopt I+} +{$define IOCheckWasOn} +{$I-} +{$endif opt I+} + +{$ifopt Q+} +{$define OverflowCheckWasOn} +{$Q-} +{$endif opt Q+} + +{***************************************************************************** + Miscellaneous +*****************************************************************************} + +procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc; +begin + HandleErrorFrame(201,get_frame); +end; + + +procedure fpc_divbyzero;[public,alias:'FPC_DIVBYZERO']; compilerproc; +begin + HandleErrorFrame(200,get_frame); +end; + + +procedure fpc_overflow;[public,alias:'FPC_OVERFLOW']; compilerproc; +begin + HandleErrorFrame(215,get_frame); +end; + + +procedure fpc_threaderror; [public,alias:'FPC_THREADERROR']; +begin + HandleErrorFrame(6,get_frame); +end; + +(* +procedure fpc_iocheck;[public,alias:'FPC_IOCHECK']; compilerproc; +var + l : longint; + HInoutRes : PWord; +begin + HInOutRes:=@InoutRes; + if HInOutRes^<>0 then + begin + l:=HInOutRes^; + HInOutRes^:=0; + HandleErrorFrame(l,get_frame); + end; +end; + + +Function IOResult:Word; +var + HInoutRes : PWord; +Begin + HInoutRes:=@InoutRes; + IOResult:=HInOutRes^; + HInOutRes^:=0; +End; + + +Function GetThreadID:TThreadID;{$ifdef SYSTEMINLINE}inline;{$endif} +begin +(* ThreadID is stored in a threadvar and made available in interface *) +(* to allow setup of this value during thread initialization. *) + GetThreadID := ThreadID; +end; + + +function fpc_safecallcheck(res : hresult) : hresult;[public,alias:'FPC_SAFECALLCHECK']; compilerproc; {$ifdef CPU86} register; {$endif} +begin + if res<0 then + begin + if assigned(SafeCallErrorProc) then + SafeCallErrorProc(res,get_frame); + HandleErrorFrame(229,get_frame); + end; + result:=res; +end; +*) + +{***************************************************************************** + Stack check code +*****************************************************************************} + +{ be compatible with old code } +{$ifdef FPC_NO_GENERIC_STACK_CHECK} +{$define NO_GENERIC_STACK_CHECK} +{$endif FPC_NO_GENERIC_STACK_CHECK} + +{$IFNDEF NO_GENERIC_STACK_CHECK} + +{$IFOPT S+} +{$DEFINE STACKCHECK} +{$ENDIF} +{$S-} +procedure fpc_stackcheck(stack_size:SizeUInt);[public,alias:'FPC_STACKCHECK']; +var + c : Pointer; +begin + { Avoid recursive calls when called from the exit routines } + if StackError then + exit; + { don't use sack_size, since the stack pointer has already been + decreased when this routine is called + } + c := Sptr - STACK_MARGIN; + if (c <= StackBottom) then + begin + StackError:=true; + HandleError(202); + end; +end; +{$IFDEF STACKCHECK} +{$S+} +{$ENDIF} +{$UNDEF STACKCHECK} + +{$ENDIF NO_GENERIC_STACK_CHECK} + +{***************************************************************************** + Initialization / Finalization +*****************************************************************************} +(* +const + maxunits=1024; { See also files.pas of the compiler source } +type + TInitFinalRec=record + InitProc, + FinalProc : TProcedure; + end; + TInitFinalTable = record + TableCount, + InitCount : longint; + Procs : array[1..maxunits] of TInitFinalRec; + end; + PInitFinalTable = ^TInitFinalTable; + + +{$ifndef FPC_HAS_INDIRECT_MAIN_INFORMATION} +var + InitFinalTable : TInitFinalTable;external name 'INITFINAL'; +{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} + + +procedure fpc_InitializeUnits;[public,alias:'FPC_INITIALIZEUNITS']; compilerproc; +var + i : longint; +begin + { call cpu/fpu initialisation routine } + fpc_cpuinit; +{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION} + with PInitFinalTable(EntryInformation.InitFinalTable)^ do +{$else FPC_HAS_INDIRECT_MAIN_INFORMATION} + with InitFinalTable do +{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} + begin + for i:=1 to TableCount do + begin + if assigned(Procs[i].InitProc) then + Procs[i].InitProc(); + InitCount:=i; + end; + end; + if assigned(InitProc) then + TProcedure(InitProc)(); +end; + + +procedure internal_initializeunits; external name 'FPC_INITIALIZEUNITS'; + +procedure fpc_LibInitializeUnits;[public,alias:'FPC_LIBINITIALIZEUNITS']; +begin + IsLibrary:=true; + { must also be set to true for packages when implemented } + ModuleIsLib:=true; + internal_initializeunits; +end; + + +procedure FinalizeUnits;[public,alias:'FPC_FINALIZEUNITS']; +begin +{$ifdef FPC_HAS_INDIRECT_MAIN_INFORMATION} + with PInitFinalTable(EntryInformation.InitFinalTable)^ do +{$else FPC_HAS_INDIRECT_MAIN_INFORMATION} + with InitFinalTable do +{$endif FPC_HAS_INDIRECT_MAIN_INFORMATION} + begin + while (InitCount>0) do + begin + // we've to decrement the cound before calling the final. code + // else a halt in the final. code leads to a endless loop + dec(InitCount); + if assigned(Procs[InitCount+1].FinalProc) then + Procs[InitCount+1].FinalProc(); + end; + end; +end; +*) +{***************************************************************************** + Error / Exit / ExitProc +*****************************************************************************} + +Procedure system_exit;forward; +{$ifdef FPC_HAS_FEATURE_HEAP} +{$ifndef HAS_MEMORYMANAGER} +//not needed if independant memory manager +Procedure FinalizeHeap;forward; +{$endif HAS_MEMORYMANAGER} +{$endif FPC_HAS_FEATURE_HEAP} + +{$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); + 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(StdErr).Mode=fmOutput then + Flush(StdErr); +end; +{$endif FPC_HAS_FEATURE_CONSOLEIO} + + +Procedure InternalExit; +(* +var + current_exit : Procedure; +{$if defined(MSWINDOWS) or defined(OS2)} + i : longint; +{$endif} +*) +Begin +(* +{$ifdef SYSTEMDEBUG} + writeln('InternalExit'); +{$endif SYSTEMDEBUG} + while exitProc<>nil Do + Begin + InOutRes:=0; + current_exit:=tProcedure(exitProc); + exitProc:=nil; + current_exit(); + End; + { Finalize units } + FinalizeUnits; + +{$ifdef FPC_HAS_FEATURE_CONSOLEIO} + SysFlushStdIO; +{$endif FPC_HAS_FEATURE_CONSOLEIO} + +{$if defined(MSWINDOWS) or defined(OS2)} + { finally release the heap if possible, especially + important for DLLs. + Reset the array to nil, and finally also argv itself to + avoid double freeing problem in case this function gets called twice. } + if assigned(argv) then + begin + for i:=0 to argc-1 do + if assigned(argv[i]) then + begin + sysfreemem(argv[i]); + argv[i]:=nil; + end; + sysfreemem(argv); + argv:=nil; + end; +{$endif} +{$ifdef LINUX} + {sysfreemem already checks for nil} + sysfreemem(calculated_cmdline); +{$endif} +{$ifdef BSD} + sysfreemem(cmdline); +{$endif} + +{$ifdef FPC_HAS_FEATURE_HEAP} +{$ifndef HAS_MEMORYMANAGER} + FinalizeHeap; +{$endif HAS_MEMORYMANAGER} +{$endif FPC_HAS_FEATURE_HEAP} +*) +End; + + +Procedure do_exit;[Public,Alias:'FPC_DO_EXIT']; +begin + InternalExit; + System_exit; +end; + + +Procedure lib_exit;[Public,Alias:'FPC_LIB_EXIT']; +begin + InternalExit; +end; + + +Procedure Halt(ErrNum: Longint); +Begin + ExitCode:=Errnum; + Do_Exit; +end; + +(* +function SysBackTraceStr (Addr: Pointer): ShortString; +begin + SysBackTraceStr:=' $'+hexstr(addr); +end; +*) + + + +Procedure HandleErrorAddrFrame (Errno : longint;addr,frame : Pointer);[public,alias:'FPC_BREAK_ERROR']; {$ifdef CPU86} register; {$endif} +begin + raise FpcRunTimeError.Create(Errno); +(* + If pointer(ErrorProc)<>Nil then + ErrorProc(Errno,addr,frame); + errorcode:=word(Errno); + erroraddr:=addr; + errorbase:=frame; +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} + if ExceptAddrStack <> nil then + raise TObject(nil) at addr,frame; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} + +{$ifdef FPC_HAS_FEATURE_EXITCODE} +{$ifdef FPC_LIMITED_EXITCODE} + if errorcode > maxExitCode then + halt(255) + else +{$endif FPC_LIMITED_EXITCODE} + halt(errorcode); +{$else FPC_HAS_FEATURE_EXITCODE} + halt; +{$endif FPC_HAS_FEATURE_EXITCODE} +*) +end; + +Procedure HandleErrorFrame (Errno : longint;frame : Pointer); +{ + Procedure to handle internal errors, i.e. not user-invoked errors + Internal function should ALWAYS call HandleError instead of RunError. + Can be used for exception handlers to specify the frame +} +begin + HandleErrorAddrFrame(Errno,get_caller_addr(frame),get_caller_frame(frame)); +end; + + +Procedure HandleError (Errno : longint);[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 + HandleErrorFrame(Errno,get_frame); +end; + + +procedure RunError(w : word);[alias: 'FPC_RUNERROR']; +begin + errorcode:=w; +(* + erroraddr:=get_caller_addr(get_frame); + errorbase:=get_caller_frame(get_frame); + *) +{$ifdef FPC_HAS_FEATURE_EXITCODE} +{$ifdef FPC_LIMITED_EXITCODE} + if errorcode > maxExitCode then + halt(255) + else +{$endif FPC_LIMITED_EXITCODE} + halt(errorcode); +{$else FPC_HAS_FEATURE_EXITCODE} + halt; +{$endif FPC_HAS_FEATURE_EXITCODE} +end; + + +Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + RunError (0); +End; + + +Procedure Halt;{$ifdef SYSTEMINLINE}inline;{$endif} +Begin + Halt(0); +End; + +Procedure Error(RunTimeError : TRunTimeError); + +begin + RunError(RuntimeErrorExitCodes[RunTimeError]); +end; + + +{$ifdef FPC_HAS_FEATURE_CONSOLEIO} +Procedure dump_stack(var f : text;bp : Pointer); +var + i : Longint; + prevbp : Pointer; + is_dev : boolean; + caller_frame, + caller_addr : Pointer; +Begin +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} + try +{$endif FPC_HAS_FEATURE_EXCEPTIONS} + prevbp:=bp-1; + i:=0; + is_dev:=do_isdevice(textrec(f).Handle); + while bp > prevbp Do + Begin + caller_addr := get_caller_addr(bp); + caller_frame := get_caller_frame(bp); + if (caller_addr=nil) then + break; + Writeln(f,BackTraceStrFunc(caller_addr)); + if (caller_frame=nil) then + break; + Inc(i); + If ((i>max_frame_dump) and is_dev) or (i>256) Then + break; + prevbp:=bp; + bp:=caller_frame; + End; +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} + except + { prevent endless dump if an exception occured } + end; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} +End; + + +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} +procedure DumpExceptionBackTrace(var f:text); +var + FrameNumber, + FrameCount : longint; + Frames : PPointer; +begin + if RaiseList=nil then + exit; + WriteLn(f,BackTraceStrFunc(RaiseList^.Addr)); + FrameCount:=RaiseList^.Framecount; + Frames:=RaiseList^.Frames; + for FrameNumber := 0 to FrameCount-1 do + WriteLn(f,BackTraceStrFunc(Frames[FrameNumber])); +end; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} + +{$endif FPC_HAS_FEATURE_CONSOLEIO} + + +{$ifdef FPC_HAS_FEATURE_HEAP} +Type + PExitProcInfo = ^TExitProcInfo; + TExitProcInfo = Record + Next : PExitProcInfo; + SaveExit : Pointer; + Proc : TProcedure; + End; +const + ExitProcList: PExitProcInfo = nil; + +Procedure DoExitProc; +var + P : PExitProcInfo; + Proc : TProcedure; +Begin + P:=ExitProcList; + ExitProcList:=P^.Next; + ExitProc:=P^.SaveExit; + Proc:=P^.Proc; + DisPose(P); + Proc(); +End; + + +Procedure AddExitProc(Proc: TProcedure); +var + P : PExitProcInfo; +Begin + New(P); + P^.Next:=ExitProcList; + P^.SaveExit:=ExitProc; + P^.Proc:=Proc; + ExitProcList:=P; + ExitProc:=@DoExitProc; +End; +{$endif FPC_HAS_FEATURE_HEAP} + + +{$ifdef FPC_HAS_FEATURE_HEAP} +function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ? +// Extra allocate reserveentries pchar's at the beginning (default param=0 after 1.0.x ?) +// Note: for internal use by skilled programmers only +// if "s" goes out of scope in the parent procedure, the pointer is dangling. + +var p : ppchar; + i : LongInt; +begin + if High(s)#0) do // count nr of args + begin + while (buf^ in [' ',#9,#10]) do // Kill separators. + inc(buf); + inc(nr); + if buf^='"' Then // quotes argument? + begin + inc(buf); + while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote + inc(buf); + if buf^='"' then // skip closing quote. + inc(buf); + end + else + begin // else std + while not (buf^ in [' ',#0,#9,#10]) do + inc(buf); + end; + end; + getmem(p,(ReserveEntries+nr)*sizeof(pchar)); + StringToPPChar:=p; + if p=nil then + begin + {$ifdef xunix} + fpseterrno(ESysEnomem); + {$endif} + exit; + end; + for i:=1 to ReserveEntries do inc(p); // skip empty slots + buf:=s; + while (buf^<>#0) do + begin + while (buf^ in [' ',#9,#10]) do // Kill separators. + begin + buf^:=#0; + inc(buf); + end; + if buf^='"' Then // quotes argument? + begin + inc(buf); + p^:=buf; + inc(p); + p^:=nil; + while not (buf^ in [#0,'"']) do // then end of argument is end of string or next quote + inc(buf); + if buf^='"' then // skip closing quote. + begin + buf^:=#0; + inc(buf); + end; + end + else + begin + p^:=buf; + inc(p); + p^:=nil; + while not (buf^ in [' ',#0,#9,#10]) do + inc(buf); + end; + end; +end; +{$endif FPC_HAS_FEATURE_HEAP} + + +{***************************************************************************** + Abstract/Assert support. +*****************************************************************************} + +procedure fpc_AbstractErrorIntern;compilerproc;[public,alias : 'FPC_ABSTRACTERROR']; +begin +(* + If pointer(AbstractErrorProc)<>nil then + AbstractErrorProc(); +*) + HandleErrorFrame(211,get_frame); +end; + + +Procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); [Public,Alias : 'FPC_ASSERT']; compilerproc; +begin +(* + if pointer(AssertErrorProc)<>nil then + AssertErrorProc(Msg,FName,LineNo,ErrorAddr) + else +*) + HandleErrorFrame(227,get_frame); +end; + + +Procedure SysAssert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); +begin +{$ifdef FPC_HAS_FEATURE_CONSOLEIO} + If msg='' then + write(stderr,'Assertion failed') + else + write(stderr,msg); + Writeln(stderr,' (',FName,', line ',LineNo,').'); + Writeln(stderr,''); +{$ifdef FPC_HAS_FEATURE_EXITCODE} + Halt(227); +{$else FPC_HAS_FEATURE_EXITCODE} + halt; +{$endif FPC_HAS_FEATURE_EXITCODE} +{$endif FPC_HAS_FEATURE_CONSOLEIO} +end; + + +{***************************************************************************** + SetJmp/LongJmp support. +*****************************************************************************} + +{$i setjump.inc} + + +{$ifdef IOCheckWasOn} +{$I+} +{$endif} + +{$ifdef RangeCheckWasOn} +{$R+} +{$endif} + +{$ifdef OverflowCheckWasOn} +{$Q+} +{$endif} + + +{***************************************************************************** + Heap +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_HEAP} +{$i sysheap.inc} + +{$i heap.inc} +{$endif FPC_HAS_FEATURE_HEAP} + +{***************************************************************************** + Thread support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_THREADING} +{ Generic threadmanager } +{$i thread.inc} + +{ Generic threadvar support } +{$i threadvr.inc} + +{$ifdef DISABLE_NO_THREAD_MANAGER} +{ OS Dependent implementation } +{$i systhrd.inc} +{$endif DISABLE_NO_THREAD_MANAGER} +{$endif FPC_HAS_FEATURE_THREADING} + + +{***************************************************************************** + File Handling +*****************************************************************************} + + +{$ifdef FPC_HAS_FEATURE_FILEIO} +{ Allow slash and backslash as separators } +procedure DoDirSeparators(p:Pchar); +var + i : longint; +begin + for i:=0 to strlen(p) do + if p[i] in AllowDirectorySeparators then + p[i]:=DirectorySeparator; +end; + +procedure DoDirSeparators(var p:shortstring); +var + i : longint; +begin + for i:=1 to length(p) do + if p[i] in AllowDirectorySeparators then + p[i]:=DirectorySeparator; +end; +{$endif FPC_HAS_FEATURE_FILEIO} + +{ OS dependent low level file functions } +{$ifdef FPC_HAS_FEATURE_FILEIO} +{$i sysfile.inc} +{$endif FPC_HAS_FEATURE_FILEIO} + +{ Text file } +{$ifdef FPC_HAS_FEATURE_TEXTIO} +{$i text.inc} +{$endif FPC_HAS_FEATURE_TEXTIO} + +{$ifdef FPC_HAS_FEATURE_FILEIO} +{ Untyped file } +{$i file.inc} + +{ Typed file } +{$i typefile.inc} +{$endif FPC_HAS_FEATURE_FILEIO} + + +{***************************************************************************** + Directory Handling +*****************************************************************************} + +{$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 } +var + s : shortstring; +begin + getdir(drivenr,s); + dir:=s; +end; +{$endif} + +{$if defined(FPC_HAS_FEATURE_FILEIO)} + +Procedure MkDir(Const s: String); +Var + Buffer: Array[0..255] of Char; +Begin + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + MkDir(@buffer[0],length(s)); +End; + +Procedure RmDir(Const s: String); +Var + Buffer: Array[0..255] of Char; +Begin + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + RmDir(@buffer[0],length(s)); +End; + +Procedure ChDir(Const s: String); +Var + Buffer: Array[0..255] of Char; +Begin + If (s='') or (InOutRes <> 0) then + exit; + Move(s[1], Buffer, Length(s)); + Buffer[Length(s)] := #0; + ChDir(@buffer[0],length(s)); +End; +{$endif} + +{***************************************************************************** + Resources support +*****************************************************************************} + +{$i sysres.inc} +(* +const + CtrlBreakHandler: TCtrlBreakHandler = nil; +{$IFNDEF FPC_HAS_SETCTRLBREAKHANDLER} +(* It is possible to provide platform specific implementation performing *) +(* special initialization; default implementation just sets the procedural *) +(* variable to make it available for use from the exception handler. *) +function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler; +begin + (* Return either nil or previous handler *) + SysSetCtrlBreakHandler := CtrlBreakHandler; + CtrlBreakHandler := Handler; +end; +{$ENDIF FPC_HAS_SETCTRLBREAKHANDLER} +*) + diff --git a/rtl/java/jsystemh.inc b/rtl/java/jsystemh.inc new file mode 100644 index 0000000000..9e09fee4c3 --- /dev/null +++ b/rtl/java/jsystemh.inc @@ -0,0 +1,733 @@ +{ + This file contains the OS independent declarations of the system unit + + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2005 by the Free Pascal development team + + See the File COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{**************************************************************************** + Processor specific routines +****************************************************************************} + +{$ifdef FPC_USE_LIBC} + {$ifdef SYSTEMINLINE} + {$define INLINEGENERICS} + {$endif} +{$endif} +(* +Procedure Move(const source;var dest;count:SizeInt); +Procedure FillChar(var x;count:SizeInt;Value:Byte); +Procedure FillChar(var x;count:SizeInt;Value:Boolean); +Procedure FillChar(var x;count:SizeInt;Value:Char); +procedure FillByte(var x;count:SizeInt;value:byte); +Procedure FillWord(var x;count:SizeInt;Value:Word); +procedure FillDWord(var x;count:SizeInt;value:DWord); +procedure FillQWord(var x;count:SizeInt;value:QWord); +function IndexChar(const buf;len:SizeInt;b:char):SizeInt; +function IndexByte(const buf;len:SizeInt;b:byte):SizeInt; +function Indexword(const buf;len:SizeInt;b:word):SizeInt; +function IndexDWord(const buf;len:SizeInt;b:DWord):SizeInt; +function IndexQWord(const buf;len:SizeInt;b:QWord):SizeInt; +function CompareChar(const buf1,buf2;len:SizeInt):SizeInt; +function CompareByte(const buf1,buf2;len:SizeInt):SizeInt; +function CompareWord(const buf1,buf2;len:SizeInt):SizeInt; +function CompareDWord(const buf1,buf2;len:SizeInt):SizeInt; +procedure MoveChar0(const buf1;var buf2;len:SizeInt); +function IndexChar0(const buf;len:SizeInt;b:char):SizeInt; +function CompareChar0(const buf1,buf2;len:SizeInt):SizeInt; +procedure prefetch(const mem);[internproc:fpc_in_prefetch_var]; +procedure ReadBarrier; +procedure ReadDependencyBarrier; +procedure ReadWriteBarrier; +procedure WriteBarrier; +*) + +{**************************************************************************** + Math Routines +****************************************************************************} + +Function lo(B: Byte):Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +Function hi(b : Byte) : Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +Function lo(i : Integer) : byte; [INTERNPROC: fpc_in_lo_Word]; +Function lo(w : Word) : byte; [INTERNPROC: fpc_in_lo_Word]; +Function lo(l : Longint) : Word; [INTERNPROC: fpc_in_lo_long]; +Function lo(l : DWord) : Word; [INTERNPROC: fpc_in_lo_long]; +Function lo(i : Int64) : DWord; [INTERNPROC: fpc_in_lo_qword]; +Function lo(q : QWord) : DWord; [INTERNPROC: fpc_in_lo_qword]; +Function hi(i : Integer) : byte; [INTERNPROC: fpc_in_hi_Word]; +Function hi(w : Word) : byte; [INTERNPROC: fpc_in_hi_Word]; +Function hi(l : Longint) : Word; [INTERNPROC: fpc_in_hi_long]; +Function hi(l : DWord) : Word; [INTERNPROC: fpc_in_hi_long]; +Function hi(i : Int64) : DWord; [INTERNPROC: fpc_in_hi_qword]; +Function hi(q : QWord) : DWord; [INTERNPROC: fpc_in_hi_qword]; + +Function swap (X : Word) : Word;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_word]; +(* Function Swap (X : Integer) : Integer;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_word]; *) +Function swap (X : Longint) : Longint;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_long]; +(* Function Swap (X : Cardinal) : Cardinal;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_long]; *) +(* Function Swap (X : QWord) : QWord;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_qword]; *) +Function swap (X : Int64) : Int64;{$ifdef SYSTEMINLINE}inline;{$endif}[internconst:fpc_in_const_swap_qword]; + +Function Align (Addr : PtrUInt; Alignment : PtrUInt) : PtrUInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* +Function Align (Addr : Pointer; Alignment : PtrUInt) : Pointer;{$ifdef SYSTEMINLINE}inline;{$endif} +*) + +{$ifdef FPC_HAS_FEATURE_RANDOM} +Function Random(l:longint):longint; +Function Random(l:int64):int64; +{$ifndef FPUNONE} +Function Random: extended; +{$endif} +Procedure Randomize; +{$endif FPC_HAS_FEATURE_RANDOM} + +{$ifdef FPC_HAS_INTERNAL_ABS_LONG and (defined(cpui386) or defined(cpux86_64) or defined(cpupowerpc))} +{$define FPC_SYSTEM_HAS_ABS_LONGINT} +Function abs(l:longint):longint;[internproc:fpc_in_abs_long]; +{$else FPC_HAS_INTERNAL_ABS_LONG} +Function abs(l:Longint):Longint;[internconst:fpc_in_const_abs];{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_ABS_LONG} +Function abs(l:Int64):Int64;[internconst:fpc_in_const_abs];{$ifdef SYSTEMINLINE}inline;{$endif} +Function sqr(l:Longint):Longint;[internconst:fpc_in_const_sqr];{$ifdef SYSTEMINLINE}inline;{$endif} +Function sqr(l:Int64):Int64;[internconst:fpc_in_const_sqr];{$ifdef SYSTEMINLINE}inline;{$endif} +(* Function sqr(l:QWord):QWord;[internconst:fpc_in_const_sqr];{$ifdef SYSTEMINLINE}inline;{$endif} *) +Function odd(l:Longint):Boolean;[internconst:fpc_in_const_odd];{$ifdef SYSTEMINLINE}inline;{$endif} +(* Function odd(l:Longword):Boolean;[internconst:fpc_in_const_odd];{$ifdef SYSTEMINLINE}inline;{$endif} *) +Function odd(l:Int64):Boolean;[internconst:fpc_in_const_odd];{$ifdef SYSTEMINLINE}inline;{$endif} +(* Function odd(l:QWord):Boolean;[internconst:fpc_in_const_odd];{$ifdef SYSTEMINLINE}inline;{$endif} *) + +function SwapEndian(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function SwapEndian(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function SwapEndian(const AValue: LongInt): LongInt; +(* function SwapEndian(const AValue: DWord): DWord; *) +function SwapEndian(const AValue: Int64): Int64; +(* function SwapEndian(const AValue: QWord): QWord; *) + +function BEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function BEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function BEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function BEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function BEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function BEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) + +function LEtoN(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function LEtoN(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function LEtoN(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function LEtoN(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function LEtoN(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function LEtoN(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) + +function NtoBE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoBE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function NtoBE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoBE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function NtoBE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoBE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) + +function NtoLE(const AValue: SmallInt): SmallInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoLE(const AValue: Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function NtoLE(const AValue: LongInt): LongInt;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoLE(const AValue: DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) +function NtoLE(const AValue: Int64): Int64;{$ifdef SYSTEMINLINE}inline;{$endif} +(* function NtoLE(const AValue: QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} *) + +{$ifdef FPC_HAS_INTERNAL_ROX} + +{$if defined(cpux86_64) or defined(cpui386)} +{$define FPC_HAS_INTERNAL_ROX_BYTE} +{$define FPC_HAS_INTERNAL_ROX_WORD} +{$endif defined(cpux86_64) or defined(cpui386)} + +{$if defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)} +{$define FPC_HAS_INTERNAL_ROX_DWORD} +{$endif defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)} + +{$if defined(cpux86_64) or defined(powerpc64)} +{$define FPC_HAS_INTERNAL_ROX_QWORD} +{$endif defined(cpux86_64) or defined(powerpc64)} + +{$endif FPC_HAS_INTERNAL_ROX} + +{$ifdef FPC_HAS_INTERNAL_ROX_BYTE} +function RorByte(Const AValue : Byte): Byte;[internproc:fpc_in_ror_x]; +function RorByte(Const AValue : Byte;const Dist : Byte): Byte;[internproc:fpc_in_ror_x_x]; + +function RolByte(Const AValue : Byte): Byte;[internproc:fpc_in_rol_x]; +function RolByte(Const AValue : Byte;const Dist : Byte): Byte;[internproc:fpc_in_rol_x_x]; +{$else FPC_HAS_INTERNAL_ROX_BYTE} +function RorByte(Const AValue : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +function RorByte(Const AValue : Byte;const Dist : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} + +function RolByte(Const AValue : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +function RolByte(Const AValue : Byte;const Dist : Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_ROX_BYTE} + + +{$ifdef FPC_HAS_INTERNAL_ROX_WORD} +function RorWord(Const AValue : Word): Word;[internproc:fpc_in_ror_x]; +function RorWord(Const AValue : Word;const Dist : Byte): Word;[internproc:fpc_in_ror_x_x]; + +function RolWord(Const AValue : Word): Word;[internproc:fpc_in_rol_x]; +function RolWord(Const AValue : Word;const Dist : Byte): Word;[internproc:fpc_in_rol_x_x]; +{$else FPC_HAS_INTERNAL_ROX_WORD} +function RorWord(Const AValue : Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} +function RorWord(Const AValue : Word;const Dist : Byte): Word;{$ifdef SYSTEMINLINE}inline;{$endif} + +function RolWord(Const AValue : Word): Word;{$ifdef SYSTEMINLINE}inline;{$endif} +function RolWord(Const AValue : Word;const Dist : Byte): Word;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_ROX_WORD} + + +{$ifdef FPC_HAS_INTERNAL_ROX_DWORD} +function RorDWord(Const AValue : DWord): DWord;[internproc:fpc_in_ror_x]; +function RorDWord(Const AValue : DWord;const Dist : Byte): DWord;[internproc:fpc_in_ror_x_x]; + +function RolDWord(Const AValue : DWord): DWord;[internproc:fpc_in_rol_x]; +function RolDWord(Const AValue : DWord;const Dist : Byte): DWord;[internproc:fpc_in_rol_x_x]; +{$else FPC_HAS_INTERNAL_ROX_DWORD} +function RorDWord(Const AValue : DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} +function RorDWord(Const AValue : DWord;const Dist : Byte): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} + +function RolDWord(Const AValue : DWord): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} +function RolDWord(Const AValue : DWord;const Dist : Byte): DWord;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_ROX_DWORD} + + +{$ifdef FPC_HAS_INTERNAL_ROX_QWORD} +function RorQWord(Const AValue : QWord): QWord;[internproc:fpc_in_ror_x]; +function RorQWord(Const AValue : QWord;const Dist : Byte): QWord;[internproc:fpc_in_ror_x_x]; + +function RolQWord(Const AValue : QWord): QWord;[internproc:fpc_in_rol_x]; +function RolQWord(Const AValue : QWord;const Dist : Byte): QWord;[internproc:fpc_in_rol_x_x]; +{$else FPC_HAS_INTERNAL_ROX_QWORD} +function RorQWord(Const AValue : QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} +function RorQWord(Const AValue : QWord;const Dist : Byte): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} + +function RolQWord(Const AValue : QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} +function RolQWord(Const AValue : QWord;const Dist : Byte): QWord;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_ROX_QWORD} + +{$ifdef FPC_HAS_INTERNAL_SAR} + +{$if defined(cpux86_64) or defined(cpui386)} +{$define FPC_HAS_INTERNAL_SAR_BYTE} +{$define FPC_HAS_INTERNAL_SAR_WORD} +{$endif defined(cpux86_64) or defined(cpui386)} + +{ 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)} +{$define FPC_HAS_INTERNAL_SAR_DWORD} +{ $endif defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)} + +{$if defined(cpux86_64) or defined(powerpc64)} +{$define FPC_HAS_INTERNAL_SAR_QWORD} +{$endif defined(cpux86_64) or defined(powerpc64)} + +{$endif FPC_HAS_INTERNAL_SAR} + +{$ifdef FPC_HAS_INTERNAL_SAR_BYTE} +function SarShortint(Const AValue : Shortint): Shortint;[internproc:fpc_in_sar_x]; +function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;[internproc:fpc_in_sar_x_y]; +{$else FPC_HAS_INTERNAL_ROX_BYTE} +function SarShortint(Const AValue : Shortint;const Shift : Byte = 1): Shortint; +{$endif FPC_HAS_INTERNAL_ROX_BYTE} + +{$ifdef FPC_HAS_INTERNAL_SAR_WORD} +function SarSmallint(Const AValue : Smallint): Smallint;[internproc:fpc_in_sar_x]; +function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;[internproc:fpc_in_sar_x_y]; +{$else FPC_HAS_INTERNAL_SAR_WORD} +function SarSmallint(Const AValue : Smallint;const Shift : Byte = 1): Smallint; +{$endif FPC_HAS_INTERNAL_SAR_WORD} + +{$ifdef FPC_HAS_INTERNAL_SAR_DWORD} +function SarLongint(Const AValue : Longint): Longint;[internproc:fpc_in_sar_x]; +function SarLongint(Const AValue : Longint;Shift : Byte): Longint;[internproc:fpc_in_sar_x_y]; +{$else FPC_HAS_INTERNAL_SAR_DWORD} +function SarLongint(Const AValue : Longint;const Shift : Byte = 1): Longint; +{$endif FPC_HAS_INTERNAL_SAR_DWORD} + +{$ifdef FPC_HAS_INTERNAL_SAR_QWORD} +function SarInt64(Const AValue : Int64): Int64;[internproc:fpc_in_sar_x]; +function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_sar_x_y]; +{$else FPC_HAS_INTERNAL_SAR_QWORD} +function SarInt64(Const AValue : Int64;const Shift : Byte = 1): Int64; +{$endif FPC_HAS_INTERNAL_SAR_QWORD} + +{$ifdef FPC_HAS_INTERNAL_BSX} +{$if defined(cpui386) or defined(cpux86_64)} +{$define FPC_HAS_INTERNAL_BSX_BYTE} +{$define FPC_HAS_INTERNAL_BSX_WORD} +{$define FPC_HAS_INTERNAL_BSX_DWORD} +{$endif} +{$if defined(cpux86_64)} +{$define FPC_HAS_INTERNAL_BSX_QWORD} +{$endif} +{$endif} + +{$ifdef FPC_HAS_INTERNAL_BSX_BYTE} +function BsfByte(Const AValue: Byte): Byte;[internproc:fpc_in_bsf_x]; +function BsrByte(Const AValue: Byte): Byte;[internproc:fpc_in_bsr_x]; +{$else} +function BsfByte(Const AValue: Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +function BsrByte(Const AValue: Byte): Byte;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif} + +{$ifdef FPC_HAS_INTERNAL_BSX_WORD} +function BsfWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsf_x]; +function BsrWord(Const AValue: Word): cardinal;[internproc:fpc_in_bsr_x]; +{$else} +function BsfWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +function BsrWord(Const AValue: Word): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif} + +{$ifdef FPC_HAS_INTERNAL_BSX_DWORD} +function BsfDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsf_x]; +function BsrDWord(Const AValue : DWord): cardinal;[internproc:fpc_in_bsr_x]; +{$else} +function BsfDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +function BsrDWord(Const AValue : DWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_BSX_DWORD} + +{$ifdef FPC_HAS_INTERNAL_BSX_QWORD} +function BsfQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsf_x]; +function BsrQWord(Const AValue : QWord): cardinal;[internproc:fpc_in_bsr_x]; +{$else} +function BsfQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +function BsrQWord(Const AValue : QWord): cardinal;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_INTERNAL_BSF_QWORD} + +{$ifndef FPUNONE} +{ float math routines } +{$I mathh.inc} +{$endif} +{ currency math routines } +{$I currh.inc} + +{**************************************************************************** + Addr/Pointer Handling +****************************************************************************} +(* +Function ptr(sel,off:Longint):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} +*) + +{**************************************************************************** + PChar and String Handling +****************************************************************************} +(* +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); +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; +Function lowerCase(const s:shortstring):shortstring; overload; +Function Space(b:byte):shortstring; +Function hexStr(Val:Longint;cnt:byte):shortstring; +Function OctStr(Val:Longint;cnt:byte):shortstring; +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:Pointer):shortstring; +*) + +{ Char functions } +Function chr(b : byte) : Char; [INTERNPROC: fpc_in_chr_byte]; +Function upCase(c:Char):Char; +Function lowerCase(c:Char):Char; overload; +(*function pos(const substr : shortstring;c:char): SizeInt;*) + + +{**************************************************************************** + AnsiString Handling +****************************************************************************} + +(* +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Procedure UniqueString(var S : AnsiString);external name 'FPC_ANSISTR_UNIQUE'; +Function Pos (const Substr : AnsiString; const Source : AnsiString) : SizeInt; +Function Pos (c : Char; const s : AnsiString) : SizeInt; +Procedure Insert (const Source : AnsiString; var S : AnsiString; Index : SizeInt); +Procedure Delete (var S : AnsiString; Index,Size: SizeInt); +Function StringOfChar(c : char;l : SizeInt) : AnsiString; +function upcase(const s : ansistring) : ansistring; +function lowercase(const s : ansistring) : ansistring; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +*) + +{**************************************************************************** + WideString Handling +****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$i ustringh.inc} + {$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} + {$i wstringh.inc} + {$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + + +{**************************************************************************** + Untyped File Management +****************************************************************************} + +{$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 Rewrite(var f:File;l:Longint); +Procedure Rewrite(var f:File); +Procedure Reset(var f:File;l:Longint); +Procedure Reset(var f:File); +Procedure Close(var f:File); +Procedure BlockWrite(var f:File;const Buf;Count:Int64;var Result:Int64); +Procedure BlockWrite(var f:File;const Buf;Count:Longint;var Result:Longint); +Procedure BlockWrite(var f:File;const Buf;Count:Cardinal;var Result:Cardinal); +Procedure BlockWrite(var f:File;const Buf;Count:Word;var Result:Word); +Procedure BlockWrite(var f:File;const Buf;Count:Word;var Result:Integer); +Procedure BlockWrite(var f:File;const Buf;Count:Longint); +Procedure BlockRead(var f:File;var Buf;count:Int64;var Result:Int64); +Procedure BlockRead(var f:File;var Buf;count:Longint;var Result:Longint); +Procedure BlockRead(var f:File;var Buf;count:Cardinal;var Result:Cardinal); +Procedure BlockRead(var f:File;var Buf;count:Word;var Result:Word); +Procedure BlockRead(var f:File;var Buf;count:Word;var Result:Integer); +Procedure BlockRead(var f:File;var Buf;count:Int64); +Function FilePos(var f:File):Int64; +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} + + +{**************************************************************************** + Typed File Management +****************************************************************************} + +{$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 Reset(var f : TypedFile); [INTERNPROC: fpc_in_Reset_TypedFile]; +Procedure Rewrite(var f : TypedFile); [INTERNPROC: fpc_in_Rewrite_TypedFile]; +{$endif FPC_HAS_FEATURE_FILEIO} + +{**************************************************************************** + Text File Management +****************************************************************************} + +{$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 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; +Function EOLn:Boolean; +Function SeekEOLn (var t:Text):Boolean; +Function SeekEOF (var t:Text):Boolean; +Function SeekEOLn:Boolean; +Function SeekEOF:Boolean; +Procedure SetTextBuf(var f:Text; var Buf);[INTERNPROC:fpc_in_settextbuf_file_x]; +Procedure SetTextBuf(var f:Text; var Buf; Size:SizeInt); +Procedure SetTextLineEnding(var f:Text; Ending:string); +{$endif FPC_HAS_FEATURE_TEXTIO} + +{**************************************************************************** + 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); +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Procedure getdir(drivenr:byte;var dir:ansistring); +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +{$endif FPC_HAS_FEATURE_FILEIO} + +{***************************************************************************** + Miscellaneous +*****************************************************************************} + +{ os independent calls to allow backtraces } +{$IFDEF INTERNAL_BACKTRACE} +// inserted in compiler/psystem.pas +//function get_frame:pointer;[INTERNPROC:fpc_in_get_frame]; +(* +// still defined externally +function get_caller_addr(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_addr]; +function get_caller_frame(framebp:pointer):pointer;[INTERNPROC:fpc_in_get_caller_frame]; +*) +{$ELSE} +function get_frame:pointer;{$ifdef SYSTEMINLINE}inline;{$endif} +{$ENDIF} +(* +function get_caller_addr(framebp:pointer):pointer; +function get_caller_frame(framebp:pointer):pointer; +*) + +//Function IOResult:Word; +//Function Sptr:Pointer;[internconst:fpc_in_const_ptr]; + +{$ifdef FPC_HAS_FEATURE_PROCESSES} +Function GetProcessID:SizeUInt; +Function GetThreadID:TThreadID;{$ifdef SYSTEMINLINE}inline;{$endif} +{$endif FPC_HAS_FEATURE_PROCESSES} + +(* +function InterLockedIncrement (var Target: longint) : longint; public name 'FPC_INTERLOCKEDINCREMENT'; +function InterLockedDecrement (var Target: longint) : longint; public name 'FPC_INTERLOCKEDDECREMENT'; +function InterLockedExchange (var Target: longint;Source : longint) : longint; public name 'FPC_INTERLOCKEDEXCHANGE'; +function InterLockedExchangeAdd (var Target: longint;Source : longint) : longint; public name 'FPC_INTERLOCKEDEXCHANGEADD'; +function InterlockedCompareExchange(var Target: longint; NewValue: longint; Comperand: longint): longint; public name 'FPC_INTERLOCKEDCOMPAREEXCHANGE'; +{$ifdef cpu64} +function InterLockedIncrement64 (var Target: int64) : int64; public name 'FPC_INTERLOCKEDINCREMENT64'; +function InterLockedDecrement64 (var Target: int64) : int64; public name 'FPC_INTERLOCKEDDECREMENT64'; +function InterLockedExchange64 (var Target: int64;Source : int64) : int64; public name 'FPC_INTERLOCKEDEXCHANGE64'; +function InterLockedExchangeAdd64 (var Target: int64;Source : int64) : int64; public name 'FPC_INTERLOCKEDEXCHANGEADD64'; +function InterlockedCompareExchange64(var Target: int64; NewValue: int64; Comperand: int64): int64; public name 'FPC_INTERLOCKEDCOMPAREEXCHANGE64'; +{$endif cpu64} +{ Pointer overloads } +{$ifdef cpu64} +function InterLockedIncrement (var Target: Pointer) : Pointer; external name 'FPC_INTERLOCKEDINCREMENT64'; +function InterLockedDecrement (var Target: Pointer) : Pointer; external name 'FPC_INTERLOCKEDDECREMENT64'; +function InterLockedExchange (var Target: Pointer;Source : Pointer) : Pointer; external name 'FPC_INTERLOCKEDEXCHANGE64'; +function InterLockedExchangeAdd (var Target: Pointer;Source : Pointer) : Pointer; external name 'FPC_INTERLOCKEDEXCHANGEADD64'; +function InterlockedCompareExchange(var Target: Pointer; NewValue: Pointer; Comperand: Pointer): Pointer; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE64'; +{$else cpu64} +function InterLockedIncrement (var Target: Pointer) : Pointer; external name 'FPC_INTERLOCKEDINCREMENT'; +function InterLockedDecrement (var Target: Pointer) : Pointer; external name 'FPC_INTERLOCKEDDECREMENT'; +function InterLockedExchange (var Target: Pointer;Source : Pointer) : Pointer; external name 'FPC_INTERLOCKEDEXCHANGE'; +function InterLockedExchangeAdd (var Target: Pointer;Source : Pointer) : Pointer; external name 'FPC_INTERLOCKEDEXCHANGEADD'; +function InterlockedCompareExchange(var Target: Pointer; NewValue: Pointer; Comperand: Pointer): Pointer; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE'; +{$endif cpu64} +{ unsigned overloads } +function InterLockedIncrement (var Target: cardinal) : cardinal; external name 'FPC_INTERLOCKEDINCREMENT'; +function InterLockedDecrement (var Target: cardinal) : cardinal; external name 'FPC_INTERLOCKEDDECREMENT'; +function InterLockedExchange (var Target: cardinal;Source : cardinal) : cardinal; external name 'FPC_INTERLOCKEDEXCHANGE'; +function InterLockedExchangeAdd (var Target: cardinal;Source : cardinal) : cardinal; external name 'FPC_INTERLOCKEDEXCHANGEADD'; +function InterlockedCompareExchange(var Target: cardinal; NewValue: cardinal; Comperand: cardinal): cardinal; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE'; +{$ifdef cpu64} +function InterLockedIncrement64 (var Target: qword) : qword; external name 'FPC_INTERLOCKEDINCREMENT64'; +function InterLockedDecrement64 (var Target: qword) : qword; external name 'FPC_INTERLOCKEDDECREMENT64'; +function InterLockedExchange64 (var Target: qword;Source : qword) : qword; external name 'FPC_INTERLOCKEDEXCHANGE64'; +function InterLockedExchangeAdd64 (var Target: qword;Source : qword) : qword; external name 'FPC_INTERLOCKEDEXCHANGEADD64'; +function InterlockedCompareExchange64(var Target: qword; NewValue: qword; Comperand: qword): int64; external name 'FPC_INTERLOCKEDCOMPAREEXCHANGE64'; +{$endif cpu64} +*) + +{***************************************************************************** + Init / Exit / ExitProc +*****************************************************************************} + +type + TRuntimeError = + (reNone, reOutOfMemory, reInvalidPtr, reDivByZero, reRangeError, + reIntOverflow, reInvalidOp, reZeroDivide, reOverflow, reUnderflow, + reInvalidCast, reAccessViolation, rePrivInstruction, reControlBreak, + reStackOverflow, reVarTypeCast, reVarInvalidOp, reVarDispatch, + reVarArrayCreate, reVarNotArray, reVarArrayBounds, reAssertionFailed, + reExternalException, reIntfCastError, reSafeCallError, reQuit, + reCodesetConversion); + +Const + // Please keep locations corresponding to location in array above + RuntimeErrorExitCodes : Array[TRuntimeError] of Byte = ( + 0 , 203, 204, 200, 201, + 215, 207, 200, 205, 206, + 219, 216, 218, 217, + 202, 220, 221, 222, + 223, 224, 225, 227, + 212, 228, 229, 233, + 234); + +Procedure Error(RunTimeError : TRunTimeError); +{$ifdef FPC_HAS_FEATURE_COMMANDARGS} +Function Paramcount:Longint; +Function ParamStr(l:Longint):string; +{$endif FPC_HAS_FEATURE_COMMANDARGS} + +{$ifdef FPC_HAS_FEATURE_CONSOLEIO} +Procedure Dump_Stack(var f : text;bp:pointer); +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} +procedure DumpExceptionBackTrace(var f:text); +{$endif FPC_HAS_FEATURE_EXCEPTIONS} +{$endif FPC_HAS_FEATURE_CONSOLEIO} + +Procedure RunError(w:Word); +Procedure RunError;{$ifdef SYSTEMINLINE}inline;{$endif} +Procedure halt(errnum:Longint); +{$ifdef FPC_HAS_FEATURE_HEAP} +Procedure AddExitProc(Proc:TProcedure); +{$endif FPC_HAS_FEATURE_HEAP} +Procedure halt;{$ifdef SYSTEMINLINE}inline;{$endif} + +{ Need to be exported for threads unit } +(* +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} +Procedure SysInitExceptions; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} +*) +{$ifdef FPC_HAS_FEATURE_CONSOLEIO} +procedure SysInitStdIO; +procedure SysFlushStdIO; +{$endif FPC_HAS_FEATURE_CONSOLEIO} +{$ifndef FPUNONE} +Procedure SysResetFPU; +Procedure SysInitFPU; +{$endif} + +{***************************************************************************** + Abstract/Assert/Error Handling +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_HEAP} +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +function ArrayStringToPPchar(const S:Array of AnsiString;reserveentries:Longint):ppchar; // const ? +Function StringToPPChar(var S:AnsiString;ReserveEntries:integer):ppchar; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +Function StringToPPChar(S: PChar;ReserveEntries:integer):ppchar; +{$endif FPC_HAS_FEATURE_HEAP} + + +(* +procedure AbstractError;external name 'FPC_ABSTRACTERROR'; +Function SysBackTraceStr(Addr:Pointer): ShortString; +Procedure SysAssert(const Msg,FName:ShortString;LineNo:Longint;ErrorAddr:Pointer); +*) +(* Supposed to return address of previous CtrlBreakHandler *) +(* (may be nil), returned value of pointer (-1) means that *) +(* attempt to setup CtrlBreakHandler wasn't successful. *) +(* +function SysSetCtrlBreakHandler (Handler: TCtrlBreakHandler): TCtrlBreakHandler; +*) + +{ Error handlers } +(* +Type + TBackTraceStrFunc = Function (Addr: Pointer): ShortString; + TErrorProc = Procedure (ErrNo : Longint; Address,Frame : Pointer); + TAbstractErrorProc = Procedure; + TAssertErrorProc = Procedure(const msg,fname:ShortString;lineno:longint;erroraddr:pointer); + TSafeCallErrorProc = Procedure(error : HResult;addr : pointer); + +const + BackTraceStrFunc : TBackTraceStrFunc = @SysBackTraceStr; + ErrorProc : TErrorProc = nil; + AbstractErrorProc : TAbstractErrorProc = nil; + AssertErrorProc : TAssertErrorProc = @SysAssert; + SafeCallErrorProc : TSafeCallErrorProc = nil; +*) + +{***************************************************************************** + SetJmp/LongJmp +*****************************************************************************} + +{$i setjumph.inc} + + +{***************************************************************************** + Object Pascal support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_CLASSES} +{$i objpash.inc} +{$endif FPC_HAS_FEATURE_CLASSES} + +{***************************************************************************** + Variant support +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_VARIANTS} +{$i varianth.inc} +{$endif FPC_HAS_FEATURE_VARIANTS} + +{***************************************************************************** + Internal helper routines support +*****************************************************************************} +(* +{$ifdef FPC_HAS_FEATURE_DYNARRAYS} +{$i dynarrh.inc} +{$endif FPC_HAS_FEATURE_DYNARRAYS} +*) +{ documenting compiler proc. is useless, they shouldn't be used by the user anyways } +(* +{$ifndef fpdocsystem} +{$i compproc.inc} +{$endif fpdocsystem} +*) +{***************************************************************************** + Heap +*****************************************************************************} + +{$ifdef FPC_HAS_FEATURE_HEAP} +{$i heaph.inc} +{$endif FPC_HAS_FEATURE_HEAP} + +{***************************************************************************** + Thread support +*****************************************************************************} + +{ Generic threadmanager } +{$ifdef FPC_HAS_FEATURE_THREADING} +{$i threadh.inc} +{$endif FPC_HAS_FEATURE_THREADING} + +{***************************************************************************** + Resources support +*****************************************************************************} +(* +{$i resh.inc} +*) +{***************************************************************************** + FPDoc phony declarations. +*****************************************************************************} + +{$ifdef fpdocsystem} +{$i system.fpd} +{$endif} diff --git a/rtl/java/jsystemh_types.inc b/rtl/java/jsystemh_types.inc new file mode 100644 index 0000000000..ae55d09c50 --- /dev/null +++ b/rtl/java/jsystemh_types.inc @@ -0,0 +1,521 @@ +{ + This file contains the OS independent declarations of the system unit + + This file is part of the Free Pascal Run time library. + Copyright (c) 1999-2005 by the Free Pascal development team + + See the File COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{**************************************************************************** + Needed switches +****************************************************************************} + +{$I-,Q-,H-,R-,V-} +{$mode objfpc} + +{ At least 2.4.0 is required } +{$if defined(VER1) or defined(VER2_0) or defined(VER2_2) } + {$fatal You need at least FPC 2.4.0 to build this version of FPC} +{$endif} + +{ Using inlining for small system functions/wrappers } +{$inline on} +{$define SYSTEMINLINE} + +{ don't use FPU registervariables on the i386 } +{$ifdef CPUI386} + {$maxfpuregisters 0} +{$endif CPUI386} + +{ the assembler helpers need this} +{$ifdef CPUPOWERPC} + {$goto+} +{$endif CPUPOWERPC} + +{$ifdef CPUAVR} + {$goto+} +{$endif CPUAVR} + + +{ needed for insert,delete,readln } +{$P+} +{ stack checking always disabled + for system unit. This is because + the startup code might not + have been called yet when we + get a stack error, this will + cause big crashes +} +{$S-} + +{**************************************************************************** + Global Types and Constants +****************************************************************************} + +Type + { The compiler has all integer types defined internally. Here + we define only aliases } + DWord = LongWord; + Cardinal = LongWord; + Integer = SmallInt; + UInt64 = QWord; + + { moved here from psystem.pas + Delphi allows chose of overloaded procedure depending + on Real <-> Double, so use type here, see also tw7425.pp (FK) } +{$ifndef FPUNONE} + Real = type Double; +{$endif} + +{$ifdef CPUI386} + {$define CPU32} + + {$define DEFAULT_EXTENDED} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + {$define SUPPORT_EXTENDED} + {$define SUPPORT_COMP} + + {$ifndef FPUNONE} + ValReal = Extended; + {$endif} +{$endif CPUI386} + +{$ifdef CPUX86_64} +{$ifdef FPC_HAS_TYPE_EXTENDED} + { win64 doesn't support the legacy fpu } + {$define DEFAULT_EXTENDED} + {$define SUPPORT_EXTENDED} + {$define SUPPORT_COMP} + {$ifndef FPUNONE} + ValReal = Extended; + {$endif} +{$else FPC_HAS_TYPE_EXTENDED} + {$define DEFAULT_DOUBLE} + {$ifndef FPUNONE} + ValReal = Double; + {$endif} + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; +{$endif FPC_HAS_TYPE_EXTENDED} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + +{$endif CPUX86_64} + +{$ifdef CPUM68K} + {$define DEFAULT_DOUBLE} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + {$ifndef FPUNONE} + ValReal = Real; + {$endif} + + { Comp type does not exist on fpu } + Comp = int64; + PComp = ^Comp; + + FarPointer = Pointer; +{$endif CPUM68K} + +{$ifdef CPUPOWERPC} + {$define DEFAULT_DOUBLE} + + {$ifndef FPUNONE} + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + {$define FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} + + ValReal = Double; + {$endif} + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; + + FarPointer = Pointer; +{$endif CPUPOWERPC} + +{$ifdef CPUSPARC} + {$define DEFAULT_DOUBLE} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + {$define FPC_INCLUDE_SOFTWARE_SHIFT_INT64} + + {$ifndef FPUNONE} + ValReal = Double; + {$endif} + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; + + FarPointer = Pointer; +{$endif CPUSPARC} + +{$ifdef CPUARM} + {$define DEFAULT_DOUBLE} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + {$define FPC_INCLUDE_SOFTWARE_MOD_DIV} + {$define FPC_INCLUDE_SOFTWARE_SHIFT_INT64} + {$define FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} + + {$ifndef FPUNONE} + ValReal = Real; + {$endif} + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; + + FarPointer = Pointer; +{$endif CPUARM} + +{$ifdef CPUAVR} + {$define DEFAULT_SINGLE} + + {$define FPC_INCLUDE_SOFTWARE_MOD_DIV} + {$define FPC_INCLUDE_SOFTWARE_MUL} + {$define FPC_INCLUDE_SOFTWARE_SHIFT_INT64} + + {$ifndef FPUNONE} + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + {$define FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} + + ValReal = Real; + {$endif} + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; + + FarPointer = Pointer; +{$endif CPUARM} + +{$ifdef CPUJVM} + {$define DEFAULT_DOUBLE} + + {$define SUPPORT_SINGLE} + {$define SUPPORT_DOUBLE} + + ValReal = Double; + + { map comp to int64, but this doesn't mean we compile the comp support in! } + Comp = Int64; + PComp = ^Comp; +{$endif CPUJVM} + +{$ifdef CPU64} + SizeInt = Int64; + SizeUInt = QWord; + PtrInt = Int64; + PtrUInt = QWord; + ValSInt = int64; + ValUInt = qword; +{$endif CPU64} + +{$ifdef CPU32} + SizeInt = Longint; + SizeUInt = DWord; + PtrInt = Longint; + PtrUInt = DWord; + ValSInt = Longint; + ValUInt = Cardinal; +{$endif CPU32} + +{$ifdef CPU16} + SizeInt = Integer; + SizeUInt = Word; + PtrInt = Integer; + PtrUInt = Word; + ValSInt = Integer; + ValUInt = Word; +{$endif CPU16} + + NativeInt = PtrInt; + NativeUint = PtrUint; +(* +{ Zero - terminated strings } + PChar = ^Char; + PPChar = ^PChar; + PPPChar = ^PPChar; +*) + { AnsiChar is equivalent of Char, so we need + to use type renamings } + TAnsiChar = Char; + AnsiChar = Char; +(* + PAnsiChar = PChar; + PPAnsiChar = PPChar; +*) + + UCS4Char = type 0..$10ffff; +(* + PUCS4Char = ^UCS4Char; +*) +{$ifdef CPU16} + TUCS4CharArray = array[0..32767 div sizeof(UCS4Char)-1] of UCS4Char; +{$else CPU16} + TUCS4CharArray = array[0..$effffff] of UCS4Char; +{$endif CPU16} +(* + PUCS4CharArray = ^TUCS4CharArray; +*) + UCS4String = array of UCS4Char; + + UTF8String = type ansistring; +(* + PUTF8String = ^UTF8String; +*) + + HRESULT = type Longint; +{$ifndef FPUNONE} + TDateTime = type Double; + TDate = type TDateTime; + TTime = type TDateTime; +{$endif} + TError = type Longint; + +{$ifndef FPUNONE} +(* + PSingle = ^Single; + PDouble = ^Double; + PExtended = ^Extended; + + PPDouble = ^PDouble; +*) +{$endif} +(* + PCurrency = ^Currency; +*) +{$ifdef SUPPORT_COMP} +(* + PComp = ^Comp; +*) +{$endif SUPPORT_COMP} +(* + PSmallInt = ^Smallint; + PShortInt = ^Shortint; + PInteger = ^Integer; + PByte = ^Byte; + PWord = ^word; + PDWord = ^DWord; + PLongWord = ^LongWord; + PLongint = ^Longint; + PCardinal = ^Cardinal; + PQWord = ^QWord; + PInt64 = ^Int64; + PPtrInt = ^PtrInt; + PPtrUInt = ^PtrUInt; + PSizeInt = ^SizeInt; + + PPByte = ^PByte; + PPLongint = ^PLongint; + + PPointer = ^Pointer; + PPPointer = ^PPointer; + + PBoolean = ^Boolean; + PWordBool = ^WordBool; + PLongBool = ^LongBool; +*) + PShortString = ^ShortString; +(* + PAnsiString = ^AnsiString; + +{$ifndef FPUNONE} + PDate = ^TDateTime; + PDateTime = ^TDateTime; +{$endif} + PError = ^TError; + PVariant = ^Variant; + POleVariant = ^OleVariant; + + PWideChar = ^WideChar; + PPWideChar = ^PWideChar; + PPPWideChar = ^PPWideChar; +*) + WChar = Widechar; + UCS2Char = WideChar; +(* + PUCS2Char = PWideChar; + PWideString = ^WideString; +*) + + UnicodeChar = WideChar; +(* + PUnicodeChar = ^UnicodeChar; + PUnicodeString = ^UnicodeString; + + { Needed for fpc_get_output } + PText = ^Text; +*) + + TTextLineBreakStyle = (tlbsLF,tlbsCRLF,tlbsCR); + +{ procedure type } + TProcedure = Procedure; + +{ platform dependent types } +{$i sysosh.inc} + +(* +type + TEntryInformation = record + InitFinalTable : Pointer; + ThreadvarTablesTable : Pointer; + asm_exit : Procedure;stdcall; + PascalMain : Procedure;stdcall; + valgrind_used : boolean; + end; +*) + +const +{ Maximum value of the biggest signed and unsigned integer type available} + MaxSIntValue = High(ValSInt); + MaxUIntValue = High(ValUInt); + +{ max. values for longint and int} + maxLongint = $7fffffff; + maxSmallint = 32767; + + maxint = maxsmallint; + +type +{$ifdef CPU16} + IntegerArray = array[0..maxSmallint div sizeof(Integer)-1] of Integer; +{$else CPU16} + IntegerArray = array[0..$effffff] of Integer; +{$endif CPU16} + PIntegerArray = ^IntegerArray; +{$ifdef CPU16} + PointerArray = array [0..32767 div sizeof(Pointer)-1] of Pointer; +{$else CPU16} + PointerArray = array [0..512*1024*1024-2] of Pointer; +{$endif CPU16} +(* + PPointerArray = ^PointerArray; +*) + + TBoundArray = array of SizeInt; +(* +{$ifdef CPU16} + TPCharArray = packed array[0..(MaxSmallint div SizeOf(PChar))-1] of PChar; +{$else CPU16} + TPCharArray = packed array[0..(MaxLongint div SizeOf(PChar))-1] of PChar; +{$endif CPU16} + PPCharArray = ^TPCharArray; +*) + +(* CtrlBreak set to true signalizes Ctrl-Break signal, otherwise Ctrl-C. *) +(* Return value of true means that the signal has been processed, false *) +(* means that default handling should be used. *) +(* +TCtrlBreakHandler = function (CtrlBreak: boolean): boolean; +*) + +const +{$ifdef cpui386} + { Always i386 or newer } + Test8086 : byte = 2; + { Always 387 or newer. Emulated if needed. } + Test8087 : byte = 3; + { will be detected at startup } + has_sse_support : boolean = false; + has_mmx_support : boolean = false; +{$endif cpui386} +{$ifdef cpum68k} + Test68000 : byte = 0; { Must be determined at startup for both } + Test68881 : byte = 0; +{$endif cpum68k} + +{ max level in dumping on error } + Max_Frame_Dump : Word = 8; +(* +{ Exit Procedure handling consts and types } + ExitProc : pointer = nil; + Erroraddr: pointer = nil; +*) + Errorcode: Word = 0; + +{ file input modes } + fmClosed = $D7B0; + fmInput = $D7B1; + fmOutput = $D7B2; + fmInOut = $D7B3; + fmAppend = $D7B4; + Filemode : byte = 2; +(* Value should be changed during system initialization as appropriate. *) + + { assume that this program will not spawn other threads, when the + first thread is started the following constants need to be filled } + IsMultiThread : longbool = FALSE; + { set to true, if a threading helper is used before a thread + manager has been installed } + ThreadingAlreadyUsed : boolean = FALSE; + { Indicates if there was an error } + StackError : boolean = FALSE; +(* + InitProc : Pointer = nil; +*) + { compatibility } + ModuleIsLib : Boolean = FALSE; + ModuleIsPackage : Boolean = FALSE; + ModuleIsCpp : Boolean = FALSE; + +var + ExitCode : Longint; (* public name 'operatingsystem_result'; *) + RandSeed : Cardinal; + { Delphi compatibility } + IsLibrary : boolean = false; + IsConsole : boolean; + { Threading support } + fpc_threadvar_relocate_proc : pointer; public name 'FPC_THREADVAR_RELOCATE'; +(* +{$ifndef HAS_CMDLINE} +{Value should be changed during system initialization as appropriate.} +var cmdline:Pchar=nil; +{$endif} +*) + +(* +ThreadVar + ThreadID : TThreadID; + { Standard In- and Output } + ErrOutput, + Output, + Input, + StdOut, + StdErr : Text; + InOutRes : Word; + { Stack checking } + StackTop, + StackBottom : Pointer; + StackLength : SizeUInt; +*) + +{ Numbers for routines that have compiler magic } +{$I innr.inc} + diff --git a/rtl/java/objpas.inc b/rtl/java/objpas.inc new file mode 100644 index 0000000000..ac50b10143 --- /dev/null +++ b/rtl/java/objpas.inc @@ -0,0 +1,38 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2011 by Jonas Maebe + member of the Free Pascal development team. + + This file implements the helper routines for TObject + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + ********************************************************************** +} + + procedure TObject.Free; + begin + if not DestructorCalled then + begin + DestructorCalled:=true; + Destroy; + end; + end; + + + destructor TObject.Destroy; + begin + end; + + + procedure TObject.Finalize; + begin + Free; + end; + + diff --git a/rtl/java/objpash.inc b/rtl/java/objpash.inc new file mode 100644 index 0000000000..d21d0bdbb3 --- /dev/null +++ b/rtl/java/objpash.inc @@ -0,0 +1,83 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 2011 by Jonas Maebe + member of the Free Pascal development team. + + This file implements the helper routines for TObject + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + ********************************************************************** +} + +type + TObject = class(JLObject) + strict private + DestructorCalled: Boolean; + public + procedure Free; + destructor Destroy; virtual; + procedure finalize; override; + end; + TClass = class of TObject; + + {$ifndef nounsupported} + const + vtInteger = 0; + vtBoolean = 1; + vtChar = 2; + {$ifndef FPUNONE} + vtExtended = 3; + {$endif} + vtString = 4; + vtPointer = 5; + vtPChar = 6; + vtObject = 7; + vtClass = 8; + vtWideChar = 9; + vtPWideChar = 10; + vtAnsiString = 11; + vtCurrency = 12; + vtVariant = 13; + vtInterface = 14; + vtWideString = 15; + vtInt64 = 16; + vtQWord = 17; + vtUnicodeString = 18; + + type + TVarRec = record + case VType : sizeint of + {$ifdef ENDIAN_BIG} + vtInteger : ({$IFDEF CPU64}integerdummy1 : Longint;{$ENDIF CPU64}VInteger: Longint); + vtBoolean : ({$IFDEF CPU64}booldummy : Longint;{$ENDIF CPU64}booldummy1,booldummy2,booldummy3: byte; VBoolean: Boolean); + vtChar : ({$IFDEF CPU64}chardummy : Longint;{$ENDIF CPU64}chardummy1,chardummy2,chardummy3: byte; VChar: Char); + vtWideChar : ({$IFDEF CPU64}widechardummy : Longint;{$ENDIF CPU64}wchardummy1,VWideChar: WideChar); + {$else ENDIAN_BIG} + vtInteger : (VInteger: Longint); + vtBoolean : (VBoolean: Boolean); + vtChar : (VChar: Char); + vtWideChar : (VWideChar: WideChar); + {$endif ENDIAN_BIG} + // vtString : (VString: PShortString); + vtPointer : (VPointer: JLObject); + vtPChar : (VPChar: JLObject); + vtObject : (VObject: TObject); + vtClass : (VClass: TClass); + vtPWideChar : (VPWideChar: JLObject); + vtAnsiString : (VAnsiString: AnsiStringClass); + vtCurrency : (VCurrency: Currency); + // vtVariant : (VVariant: PVariant); + vtInterface : (VInterface: JLObject); + vtWideString : (VWideString: JLString); + vtInt64 : (VInt64: Int64); + vtUnicodeString : (VUnicodeString: JLString); + vtQWord : (VQWord: QWord); + end; +{$endif} + diff --git a/rtl/java/rtl.cfg b/rtl/java/rtl.cfg index d65cf8a3e1..149775ea51 100644 --- a/rtl/java/rtl.cfg +++ b/rtl/java/rtl.cfg @@ -1,5 +1,5 @@ # first, disable all --Sf- +# -Sf- # uncomment to enable the stuff you want to use # include full heap management into the rtl diff --git a/rtl/java/sstringh.inc b/rtl/java/sstringh.inc index 5c6fdfb2b6..d5e2e69180 100644 --- a/rtl/java/sstringh.inc +++ b/rtl/java/sstringh.inc @@ -16,7 +16,7 @@ type TAnsiCharArray = array of ansichar; - ShortstringClass = class sealed (JLCloneable) + ShortstringClass = class sealed (JLObject,JLCloneable) public { "length byte" } curlen: byte; @@ -46,7 +46,7 @@ type function length: jint; end; - AnsiCharArrayClass = class sealed + AnsiCharArrayClass = class sealed (JLObject) class function CreateFromLiteralStringBytes(const u: unicodestring; maxlen: byte): TAnsiCharArray; static; end; diff --git a/rtl/java/sstrings.inc b/rtl/java/sstrings.inc index 87323f1c60..9529468aad 100644 --- a/rtl/java/sstrings.inc +++ b/rtl/java/sstrings.inc @@ -203,212 +203,6 @@ begin end; -procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc; -var - len: longint; -begin - len:=length(sstr); - if len>high(res) then - len:=high(res); - ShortstringClass(@res).curlen:=len; - JLSystem.ArrayCopy(JLObject(ShortstringClass(@sstr).fdata),0,JLObject(ShortstringClass(@res).fdata),0,len); -end; - - -procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc; -var - tmpres: ShortstringClass; - s1l, s2l: longint; -begin - s1l:=length(s1); - s2l:=length(s2); - if (s1l+s2l)>high(dests) then - begin - if s1l>high(dests) then - s1l:=high(dests); - s2l:=high(dests)-s1l; - end; - if ShortstringClass(@dests)=ShortstringClass(@s1) then - JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l) - else if ShortstringClass(@dests)=ShortstringClass(@s2) then - begin - JLSystem.ArrayCopy(JLObject(ShortstringClass(@dests).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l); - JLSystem.ArrayCopy(JLObject(ShortstringClass(@s1).fdata),0,JLObject(ShortstringClass(@dests).fdata),0,s1l); - end - else - begin - JLSystem.ArrayCopy(JLObject(ShortstringClass(@s1).fdata),0,JLObject(ShortstringClass(@dests).fdata),0,s1l); - JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l) - end; - ShortstringClass(@dests).curlen:=s1l+s2l; -end; - - -procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of ShortstringClass);compilerproc; -var - s2l : byte; - LowStart,i, - Len : longint; - needtemp : boolean; - tmpstr : shortstring; - p,pdest : ShortstringClass; -begin - if high(sarr)=0 then - begin - DestS:=''; - exit; - end; - lowstart:=low(sarr); - if ShortstringClass(@DestS)=sarr[lowstart] then - inc(lowstart); - { Check for another reuse, then we can't use - the append optimization and need to use a temp } - needtemp:=false; - for i:=lowstart to high(sarr) do - begin - if ShortstringClass(@DestS)=sarr[i] then - begin - needtemp:=true; - break; - end; - end; - if needtemp then - begin - lowstart:=low(sarr); - tmpstr:=''; - pdest:=ShortstringClass(@tmpstr) - end - else - begin - { Start with empty DestS if we start with concatting - the first array element } - if lowstart=low(sarr) then - DestS:=''; - pdest:=ShortstringClass(@DestS); - end; - { Concat all strings, except the string we already - copied in DestS } - Len:=pdest.curlen; - for i:=lowstart to high(sarr) do - begin - p:=sarr[i]; - if assigned(p) then - begin - s2l:=p.curlen; - if Len+s2l>high(dests) then - s2l:=high(dests)-Len; - JLSystem.ArrayCopy(JLObject(p.fdata),0,JLObject(pdest.fdata),len,s2l); - inc(Len,s2l); - end; - end; - pdest.curlen:=len; - if needtemp then - DestS:=TmpStr; -end; - - -procedure fpc_shortstr_append_shortstr(var s1:shortstring;const s2:shortstring); compilerproc; -var - s1l, s2l : integer; -begin - s1l:=length(s1); - s2l:=length(s2); - if s1l+s2l>high(s1) then - s2l:=high(s1)-s1l; - JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@s1).fdata),s1l,s2l); - s1[0]:=chr(s1l+s2l); -end; - - -function fpc_shortstr_compare(const left,right:shortstring) : longint; compilerproc; -Var - MaxI,Temp, i : SizeInt; -begin - if ShortstringClass(@left)=ShortstringClass(@right) then - begin - result:=0; - exit; - end; - Maxi:=Length(left); - temp:=Length(right); - If MaxI>Temp then - MaxI:=Temp; - if MaxI>0 then - begin - for i:=0 to MaxI-1 do - begin - result:=ord(ShortstringClass(@left).fdata[i])-ord(ShortstringClass(@right).fdata[i]); - if result<>0 then - exit; - end; - result:=Length(left)-Length(right); - end - else - result:=Length(left)-Length(right); -end; - - -function fpc_shortstr_compare_equal(const left,right:shortstring) : longint; compilerproc; -Var - MaxI,Temp : SizeInt; -begin - if ShortstringClass(@left)=ShortstringClass(@right) then - begin - result:=0; - exit; - end; - result:=ord(not JUArrays.equals(TJByteArray(ShortstringClass(@left).fdata),TJByteArray(ShortstringClass(@right).fdata))); -end; - - -procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of AnsiChar; zerobased: boolean = true); compilerproc; -var - l: longint; - index: longint; - len: byte; - foundnull: boolean; -begin - l:=high(arr)+1; - if l>=high(res)+1 then - l:=high(res) - else if l<0 then - l:=0; - if zerobased then - begin - foundnull:=false; - for index:=low(arr) to l-1 do - if arr[index]=#0 then - begin - foundnull:=true; - break; - end; - if not foundnull then - len:=l - else - len:=index; - end - else - len:=l; - JLSystem.ArrayCopy(JLObject(@arr),0,JLObject(ShortstringClass(@res).fdata),0,len); - ShortstringClass(@res).curlen:=len; -end; - - -procedure fpc_shortstr_to_chararray(out res: array of AnsiChar; const src: ShortString); compilerproc; -var - len: longint; -begin - len:=length(src); - if len>length(res) then - len:=length(res); - { make sure we don't access char 1 if length is 0 (JM) } - if len>0 then - JLSystem.ArrayCopy(JLObject(ShortstringClass(@src).fdata),0,JLObject(@res),0,len); - if len<=high(res) then - JUArrays.fill(TJByteArray(@res),len,high(res),0); -end; - - procedure fpc_Char_To_ShortStr(out res : shortstring;const c : AnsiChar) compilerproc; { Converts a WideChar to a ShortString; @@ -456,6 +250,17 @@ begin 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; @@ -465,6 +270,17 @@ begin 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; var i,j,k,MaxLen, SubstrLen : SizeInt; @@ -516,3 +332,47 @@ begin end; +function space (b : byte): shortstring; +begin + setlength(result,b); + if b>0 then + JUArrays.fill(TJByteArray(ShortstringClass(@result).fdata),0,b,ord(' ')) +end; + + +{***************************************************************************** + Str() Helpers +*****************************************************************************} + + +procedure fpc_shortstr_SInt(v : valSInt;len : SizeInt;out s : shortstring);[public,alias:'FPC_SHORTSTR_SINT']; compilerproc; +begin + int_str(v,s); + if length(s)=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { causes exception in JLSystem.arraycopy } - if (srccopylen=0) or - (dstlen=0) then - exit; - JLSystem.arraycopy(src,srcstart,dst,0,min(srccopylen,dstlen)); - end; - - -procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1); - var - i: longint; - srclen, dstlen: jint; - begin - srclen:=length(src); - dstlen:=length(dst); - if srcstart=-1 then - srcstart:=0 - else if srcstart>=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { no arraycopy, have to clone each element } - for i:=0 to min(srccopylen,dstlen)-1 do - src[srcstart+i].fpcDeepCopy(dst[i]); - end; - - -procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1); - var - i: longint; - srclen, dstlen: jint; - begin - srclen:=length(src); - dstlen:=length(dst); - if srcstart=-1 then - srcstart:=0 - else if srcstart>=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { no arraycopy, have to clone each element } - for i:=0 to min(srccopylen,dstlen)-1 do - begin - dst[i].clear; - dst[i].addAll(src[srcstart+i]); - end; - end; - - -procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1); - var - i: longint; - srclen, dstlen: jint; - begin - srclen:=length(src); - dstlen:=length(dst); - if srcstart=-1 then - srcstart:=0 - else if srcstart>=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { no arraycopy, have to clone each element } - for i:=0 to min(srccopylen,dstlen)-1 do - begin - dst[i].clear; - dst[i].addAll(src[srcstart+i]); - end; - end; - - -procedure fpc_copy_jprocvar_array(src, dst: TJProcVarArray; srcstart: jint = -1; srccopylen: jint = -1); - var - i: longint; - srclen, dstlen: jint; - begin - srclen:=length(src); - dstlen:=length(dst); - if srcstart=-1 then - srcstart:=0 - else if srcstart>=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { no arraycopy, have to clone each element } - for i:=0 to min(srccopylen,dstlen)-1 do - src[srcstart+i].fpcDeepCopy(dst[i]); - end; - - -procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1); - var - i: longint; - srclen, dstlen: jint; - begin - srclen:=length(src); - dstlen:=length(dst); - if srcstart=-1 then - srcstart:=0 - else if srcstart>=srclen then - exit; - if srccopylen=-1 then - srccopylen:=srclen - else if srcstart+srccopylen>srclen then - srccopylen:=srclen-srcstart; - { no arraycopy, have to clone each element } - for i:=0 to min(srccopylen,dstlen)-1 do - pshortstring(src[srcstart+i])^:=pshortstring(dst[i])^; - end; - - -{ 1-dimensional setlength routines } - -function fpc_setlength_dynarr_generic(aorg, anew: JLObject; deepcopy: boolean; docopy: boolean = true): JLObject; - var - orglen, newlen: jint; - begin - orglen:=0; - newlen:=0; - if not deepcopy then - begin - if assigned(aorg) then - orglen:=JLRArray.getLength(aorg) - else - orglen:=0; - if assigned(anew) then - newlen:=JLRArray.getLength(anew) - else - newlen:=0; - end; - if deepcopy or - (orglen<>newlen) then - begin - if docopy then - fpc_copy_shallow_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray; - begin - if deepcopy or - (length(aorg)<>length(anew)) then - begin - fpc_copy_jrecord_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -function fpc_setlength_dynarr_jenumset(aorg, anew: TJEnumSetArray; deepcopy: boolean): TJEnumSetArray; - begin - if deepcopy or - (length(aorg)<>length(anew)) then - begin - fpc_copy_jenumset_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -function fpc_setlength_dynarr_jbitset(aorg, anew: TJBitSetArray; deepcopy: boolean): TJBitSetArray; - begin - if deepcopy or - (length(aorg)<>length(anew)) then - begin - fpc_copy_jbitset_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -function fpc_setlength_dynarr_jprocvar(aorg, anew: TJProcVarArray; deepcopy: boolean): TJProcVarArray; - begin - if deepcopy or - (length(aorg)<>length(anew)) then - begin - fpc_copy_jprocvar_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray; - begin - if deepcopy or - (length(aorg)<>length(anew)) then - begin - fpc_copy_jshortstring_array(aorg,anew); - result:=anew - end - else - result:=aorg; - end; - - -{ multi-dimensional setlength routine } -function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: boolean; ndim: longint; eletype: jchar): TJObjectArray; - var - partdone, - i: longint; - - begin - { resize the current dimension; no need to copy the subarrays of the old - array, as the subarrays will be (re-)initialised immediately below } - { the srcstart/srccopylen always refers to the first dimension (since copy() - performs a shallow copy of a dynamic array } - result:=TJObjectArray(fpc_setlength_dynarr_generic(JLObject(aorg),JLObject(anew),deepcopy,false)); - { if aorg was empty, there's nothing else to do since result will now - contain anew, of which all other dimensions are already initialised - correctly since there are no aorg elements to copy } - if not assigned(aorg) and - not deepcopy then - exit; - partdone:=min(high(result),high(aorg)); - { ndim must be >=2 when this routine is called, since it has to return - an array of java.lang.Object! (arrays are also objects, but primitive - types are not) } - if ndim=2 then - begin - { final dimension -> copy the primitive arrays } - case eletype of - FPCJDynArrTypeRecord: - begin - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_jrecord(TJRecordArray(aorg[i]),TJRecordArray(anew[i]),deepcopy)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(anew[i]),deepcopy)); - end; - FPCJDynArrTypeEnumSet: - begin - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_jenumset(TJEnumSetArray(aorg[i]),TJEnumSetArray(anew[i]),deepcopy)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_jenumset(nil,TJEnumSetArray(anew[i]),deepcopy)); - end; - FPCJDynArrTypeBitSet: - begin - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_jbitset(TJBitSetArray(aorg[i]),TJBitSetArray(anew[i]),deepcopy)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_jbitset(nil,TJBitSetArray(anew[i]),deepcopy)); - end; - FPCJDynArrTypeProcVar: - begin - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(TJProcVarArray(aorg[i]),TJProcVarArray(anew[i]),deepcopy)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_jprocvar(nil,TJProcVarArray(anew[i]),deepcopy)); - end; - FPCJDynArrTypeShortstring: - begin - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(TShortstringArray(aorg[i]),TShortstringArray(anew[i]),deepcopy)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_jshortstring(nil,TShortstringArray(anew[i]),deepcopy)); - end; - else - begin - for i:=low(result) to partdone do - result[i]:=fpc_setlength_dynarr_generic(aorg[i],anew[i],deepcopy); - for i:=succ(partdone) to high(result) do - result[i]:=fpc_setlength_dynarr_generic(nil,anew[i],deepcopy); - end; - end; - end - else - begin - { recursively handle the next dimension } - for i:=low(result) to partdone do - result[i]:=JLObject(fpc_setlength_dynarr_multidim(TJObjectArray(aorg[i]),TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype)); - for i:=succ(partdone) to high(result) do - result[i]:=JLObject(fpc_setlength_dynarr_multidim(nil,TJObjectArray(anew[i]),deepcopy,pred(ndim),eletype)); - end; - end; - - -function fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; eletype: jchar): JLObject; - var - i: longint; - srclen: longint; - begin - if not assigned(src) then - begin - result:=nil; - exit; - end; - srclen:=JLRArray.getLength(src); - if (start=-1) and - (len=-1) then - begin - len:=srclen; - start:=0; - end - else if (start+len>srclen) then - len:=srclen-start+1; - result:=JLRArray.newInstance(src.getClass.getComponentType,len); - if ndim=1 then - begin - case eletype of - FPCJDynArrTypeRecord: - fpc_copy_jrecord_array(TJRecordArray(src),TJRecordArray(result),start,len); - FPCJDynArrTypeEnumSet: - fpc_copy_jenumset_array(TJEnumSetArray(src),TJEnumSetArray(result),start,len); - FPCJDynArrTypeBitSet: - fpc_copy_jbitset_array(TJBitSetArray(src),TJBitSetArray(result),start,len); - FPCJDynArrTypeProcvar: - fpc_copy_jprocvar_array(TJProcVarArray(src),TJProcVarArray(result),start,len); - FPCJDynArrTypeShortstring: - fpc_copy_jshortstring_array(TShortstringArray(src),TShortstringArray(result),start,len); - else - fpc_copy_shallow_array(src,result,start,len); - end - end - else - begin - for i:=0 to len-1 do - TJObjectArray(result)[i]:=fpc_dynarray_copy(TJObjectArray(src)[start+i],-1,-1,ndim-1,eletype); - end; - end; - - -{i jdynarr.inc end} - -{***************************************************************************** - Things from system.inc -*****************************************************************************} - -Procedure HandleError (Errno : longint);[public,alias : 'FPC_HANDLEERROR']; -{ - Procedure to handle internal errors, i.e. not user-invoked errors - Internal function should ALWAYS call HandleError instead of RunError. - - For now this one cannot be intercepted in Java and always simply raise an - exception. -} -begin - raise JLException.Create('Runtime error '+UnicodeString(JLInteger.valueOf(Errno).toString)); -end; - -{$ifdef SUPPORT_DOUBLE} -operator := (b:real48) d:double;{$ifdef SYSTEMINLINE}inline;{$endif} -begin - D:=real2double(b); -end; -{$endif SUPPORT_DOUBLE} - - +{$i jdynarr.inc} {***************************************************************************** Misc. System Dependent Functions *****************************************************************************} - procedure TObject.Free; - begin - if not DestructorCalled then - begin - DestructorCalled:=true; - Destroy; - end; - end; +procedure System_exit; + begin + JLRuntime.getRuntime.exit(ExitCode); + end; - destructor TObject.Destroy; - begin - end; - - - procedure TObject.Finalize; - begin - Free; - end; +procedure randomize; + begin + randseed:=JUCalendar.getInstance.getTimeInMillis; + end; {***************************************************************************** SystemUnit Initialization diff --git a/rtl/java/ustringh.inc b/rtl/java/ustringh.inc index 7b28653c93..5c3ec41bba 100644 --- a/rtl/java/ustringh.inc +++ b/rtl/java/ustringh.inc @@ -48,7 +48,7 @@ Function UpCase(c:UnicodeChar):UnicodeChar; Type { hooks for internationalization please add new procedures at the end, it makes it easier to detect new procedures } - TUnicodeStringManager = class + TUnicodeStringManager = class(JLObject) collator: JTCollator; constructor create; end; diff --git a/rtl/java/jint64.inc b/rtl/jvm/int64p.inc similarity index 91% rename from rtl/java/jint64.inc rename to rtl/jvm/int64p.inc index 89250708bd..dedaa00105 100644 --- a/rtl/java/jint64.inc +++ b/rtl/jvm/int64p.inc @@ -16,6 +16,7 @@ {$R- no range checking } {$ifndef FPC_SYSTEM_HAS_DIV_QWORD} +{$define FPC_SYSTEM_HAS_DIV_QWORD} function fpc_div_qword(n,z : qword) : qword; compilerproc; var signmask, tmpz: qword; @@ -33,6 +34,7 @@ {$ifndef FPC_SYSTEM_HAS_MOD_QWORD} +{$define FPC_SYSTEM_HAS_MOD_QWORD} function fpc_mod_qword(n,z : qword) : qword; compilerproc; var signmask, tmpz: qword; @@ -49,3 +51,7 @@ end; {$endif FPC_SYSTEM_HAS_MOD_QWORD} + +{ lie to prevent two overloads for sqr(jlong) } +{$define FPC_SYSTEM_HAS_SQR_QWORD} + diff --git a/rtl/jvm/jvm.inc b/rtl/jvm/jvm.inc new file mode 100644 index 0000000000..abec047c4f --- /dev/null +++ b/rtl/jvm/jvm.inc @@ -0,0 +1,363 @@ +{ + + This file is part of the Free Pascal run time library. + Copyright (c) 2011 by the Free Pascal development team. + + Processor dependent implementation for the system unit for + JVM + + See the file COPYING.FPC, included in this distribution, + for details about the copyright. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + + **********************************************************************} + + +{**************************************************************************** + JVM specific stuff +****************************************************************************} + +{$define FPC_SYSTEM_HAS_SYSINITFPU} +Procedure SysInitFPU;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + softfloat_exception_mask:=float_flag_underflow or float_flag_inexact or float_flag_denormal; + end; + +{$define FPC_SYSTEM_HAS_SYSRESETFPU} +Procedure SysResetFPU;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + softfloat_exception_flags:=0; + end; + + +procedure fpc_cpuinit; + begin + SysResetFPU; + if not(IsLibrary) then + SysInitFPU; + end; + + +{$define FPC_SYSTEM_HAS_GET_FRAME} +function get_frame:pointer; + begin + result:=nil; + end; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_ADDR} +function get_caller_addr(framebp:pointer):pointer; + begin + result:=nil; + end; + + +{$define FPC_SYSTEM_HAS_GET_CALLER_FRAME} +function get_caller_frame(framebp:pointer):pointer; + begin + result:=nil; + end; + + +{$define FPC_SYSTEM_HAS_SPTR} +function Sptr:Pointer; + begin + result:=nil; + end; + +{**************************************************************************** + Primitives +****************************************************************************} + +{ lie so that the non-compilable generic versions will be skipped } +{$define FPC_SYSTEM_HAS_MOVE} +{$define FPC_SYSTEM_HAS_FILLCHAR} +{$define FPC_SYSTEM_HAS_FILLWORD} +{$define FPC_SYSTEM_HAS_FILLDWORD} +{$define FPC_SYSTEM_HAS_FILLQWORD} +{$define FPC_SYSTEM_HAS_INDEXBYTE} +{$define FPC_SYSTEM_HAS_INDEXWORD} +{$define FPC_SYSTEM_HAS_INDEXDWORD} +{$define FPC_SYSTEM_HAS_INDEXQWORD} +{$define FPC_SYSTEM_HAS_COMPAREBYTE} +{$define FPC_SYSTEM_HAS_COMPAREWORD} +{$define FPC_SYSTEM_HAS_COMPAREDWORD} +{$define FPC_SYSTEM_HAS_MOVECHAR0} +{$define FPC_SYSTEM_HAS_INDEXCHAR0} +{$define FPC_SYSTEM_HAS_COMPARECHAR0} + +{**************************************************************************** + String +****************************************************************************} + +{ more lies } +{$define FPC_STRTOSHORTSTRINGPROC} +{$define FPC_SYSTEM_HAS_FPC_PCHAR_LENGTH} +{$define FPC_SYSTEM_HAS_FPC_PWIDECHAR_LENGTH} +{$define FPC_SYSTEM_HAS_FPC_PCHAR_TO_SHORTSTR} + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_ASSIGN} +procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc; +var + len: longint; +begin + len:=length(sstr); + if len>high(res) then + len:=high(res); + ShortstringClass(@res).curlen:=len; + JLSystem.ArrayCopy(JLObject(ShortstringClass(@sstr).fdata),0,JLObject(ShortstringClass(@res).fdata),0,len); +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_CONCAT} +procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc; +var + tmpres: ShortstringClass; + s1l, s2l: longint; +begin + s1l:=length(s1); + s2l:=length(s2); + if (s1l+s2l)>high(dests) then + begin + if s1l>high(dests) then + s1l:=high(dests); + s2l:=high(dests)-s1l; + end; + if ShortstringClass(@dests)=ShortstringClass(@s1) then + JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l) + else if ShortstringClass(@dests)=ShortstringClass(@s2) then + begin + JLSystem.ArrayCopy(JLObject(ShortstringClass(@dests).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l); + JLSystem.ArrayCopy(JLObject(ShortstringClass(@s1).fdata),0,JLObject(ShortstringClass(@dests).fdata),0,s1l); + end + else + begin + JLSystem.ArrayCopy(JLObject(ShortstringClass(@s1).fdata),0,JLObject(ShortstringClass(@dests).fdata),0,s1l); + JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@dests).fdata),s1l,s2l) + end; + ShortstringClass(@dests).curlen:=s1l+s2l; +end; + + +procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of ShortstringClass);compilerproc; +var + s2l : byte; + LowStart,i, + Len : longint; + needtemp : boolean; + tmpstr : shortstring; + p,pdest : ShortstringClass; +begin + if high(sarr)=0 then + begin + DestS:=''; + exit; + end; + lowstart:=low(sarr); + if ShortstringClass(@DestS)=sarr[lowstart] then + inc(lowstart); + { Check for another reuse, then we can't use + the append optimization and need to use a temp } + needtemp:=false; + for i:=lowstart to high(sarr) do + begin + if ShortstringClass(@DestS)=sarr[i] then + begin + needtemp:=true; + break; + end; + end; + if needtemp then + begin + lowstart:=low(sarr); + tmpstr:=''; + pdest:=ShortstringClass(@tmpstr) + end + else + begin + { Start with empty DestS if we start with concatting + the first array element } + if lowstart=low(sarr) then + DestS:=''; + pdest:=ShortstringClass(@DestS); + end; + { Concat all strings, except the string we already + copied in DestS } + Len:=pdest.curlen; + for i:=lowstart to high(sarr) do + begin + p:=sarr[i]; + if assigned(p) then + begin + s2l:=p.curlen; + if Len+s2l>high(dests) then + s2l:=high(dests)-Len; + JLSystem.ArrayCopy(JLObject(p.fdata),0,JLObject(pdest.fdata),len,s2l); + inc(Len,s2l); + end; + end; + pdest.curlen:=len; + if needtemp then + DestS:=TmpStr; +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_APPEND_SHORTSTR} +procedure fpc_shortstr_append_shortstr(var s1:shortstring;const s2:shortstring); compilerproc; +var + s1l, s2l : integer; +begin + s1l:=length(s1); + s2l:=length(s2); + if s1l+s2l>high(s1) then + s2l:=high(s1)-s1l; + JLSystem.ArrayCopy(JLObject(ShortstringClass(@s2).fdata),0,JLObject(ShortstringClass(@s1).fdata),s1l,s2l); + s1[0]:=chr(s1l+s2l); +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE} +function fpc_shortstr_compare(const left,right:shortstring) : longint; compilerproc; +Var + MaxI,Temp, i : SizeInt; +begin + if ShortstringClass(@left)=ShortstringClass(@right) then + begin + result:=0; + exit; + end; + Maxi:=Length(left); + temp:=Length(right); + If MaxI>Temp then + MaxI:=Temp; + if MaxI>0 then + begin + for i:=0 to MaxI-1 do + begin + result:=ord(ShortstringClass(@left).fdata[i])-ord(ShortstringClass(@right).fdata[i]); + if result<>0 then + exit; + end; + result:=Length(left)-Length(right); + end + else + result:=Length(left)-Length(right); +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_COMPARE_EQUAL} + +function fpc_shortstr_compare_intern(const left,right:shortstring) : longint; external name 'fpc_shortstr_compare'; + +function fpc_shortstr_compare_equal(const left,right:shortstring) : longint; compilerproc; +begin + { perform normal comparsion, because JUArrays.equals() only returns true if + the arrays have equal length, while we only want to compare curlen bytes } + result:=fpc_shortstr_compare_intern(left,right); +end; + + +{$define FPC_SYSTEM_HAS_FPC_CHARARRAY_TO_SHORTSTR} +procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of AnsiChar; zerobased: boolean = true); compilerproc; +var + l: longint; + index: longint; + len: byte; + foundnull: boolean; +begin + l:=high(arr)+1; + if l>=high(res)+1 then + l:=high(res) + else if l<0 then + l:=0; + if zerobased then + begin + foundnull:=false; + for index:=low(arr) to l-1 do + if arr[index]=#0 then + begin + foundnull:=true; + break; + end; + if not foundnull then + len:=l + else + len:=index; + end + else + len:=l; + JLSystem.ArrayCopy(JLObject(@arr),0,JLObject(ShortstringClass(@res).fdata),0,len); + ShortstringClass(@res).curlen:=len; +end; + + +{$define FPC_SYSTEM_HAS_FPC_SHORTSTR_TO_CHARARRAY} +procedure fpc_shortstr_to_chararray(out res: array of AnsiChar; const src: ShortString); compilerproc; +var + len: longint; +begin + len:=length(src); + if len>length(res) then + len:=length(res); + { make sure we don't access char 1 if length is 0 (JM) } + if len>0 then + JLSystem.ArrayCopy(JLObject(ShortstringClass(@src).fdata),0,JLObject(@res),0,len); + if len<=high(res) then + JUArrays.fill(TJByteArray(@res),len,high(res),0); +end; + + +{**************************************************************************** + Str() +****************************************************************************} + +{$define FPC_SYSTEM_HAS_INT_STR_LONGINT} +procedure int_str(l:longint;out s:shortstring); + begin + s:=unicodestring(JLInteger.valueOf(l).toString); + end; + + +{$define FPC_SYSTEM_HAS_INT_STR_LONGWORD} +procedure int_str_unsigned(l:longword;out s:shortstring); + begin + s:=unicodestring(JLLong.valueOf(l).toString); + end; + + +{$define FPC_SYSTEM_HAS_INT_STR_INT64} +procedure int_str(l:int64;out s:shortstring); + begin + s:=unicodestring(JLLong.valueOf(l).toString); + end; + + +{$define FPC_SYSTEM_HAS_INT_STR_QWORD} +procedure int_str_unsigned(l:qword;out s:shortstring); +var + tmp: int64; + tmpstr: JLString; + bi: JMBigInteger; +begin + tmp:=int64(l); + tmpstr:=JLLong.valueOf(tmp and $7fffffffffffffff).toString; + if tmp<0 then + begin + { no unsigned 64 bit types in Java -> use big integer to add + high(int64) to the string representation } + bi:=JMBigInteger.Create(tmpstr); + bi:=bi.add(JMBigInteger.Create('9223372036854775808')); + tmpstr:=bi.toString; + end; + s:=unicodestring(tmpstr); +end; + + +{ lies... } +{$define FPC_SYSTEM_HAS_ODD_LONGWORD} +{$define FPC_SYSTEM_HAS_ODD_QWORD} +{$define FPC_SYSTEM_HAS_SQR_QWORD} + diff --git a/rtl/java/jmath.inc b/rtl/jvm/math.inc similarity index 100% rename from rtl/java/jmath.inc rename to rtl/jvm/math.inc diff --git a/rtl/jvm/setjump.inc b/rtl/jvm/setjump.inc new file mode 100644 index 0000000000..e69de29bb2 diff --git a/rtl/jvm/setjumph.inc b/rtl/jvm/setjumph.inc new file mode 100644 index 0000000000..e69de29bb2