diff --git a/.gitattributes b/.gitattributes index 11e534045c..3dfce35cd5 100644 --- a/.gitattributes +++ b/.gitattributes @@ -7349,6 +7349,7 @@ rtl/inc/wstrings.inc svneol=native#text/plain rtl/inc/wustrings.inc svneol=native#text/plain rtl/java/Makefile svneol=native#text/plain rtl/java/Makefile.fpc svneol=native#text/plain +rtl/java/astrings.inc svneol=native#text/plain rtl/java/compproc.inc svneol=native#text/plain rtl/java/java_sys.inc svneol=native#text/plain rtl/java/java_sysh.inc svneol=native#text/plain diff --git a/compiler/jvm/njvminl.pas b/compiler/jvm/njvminl.pas index 04cb30a373..0d687260c1 100644 --- a/compiler/jvm/njvminl.pas +++ b/compiler/jvm/njvminl.pas @@ -398,6 +398,12 @@ implementation end; left:=nil; end +{$ifndef nounsupported} + else if left.resultdef.typ=stringdef then + begin + result:=cnothingnode.create; + end +{$endif} else internalerror(2011031405); end; @@ -473,6 +479,11 @@ implementation addstatement(newstatement,ctemprefnode.create(lentemp)); result:=newblock; end +{$ifndef nounsupported} + else if left.resultdef.typ=stringdef then + begin + end +{$endif} else result:=inherited first_length; end; @@ -489,6 +500,12 @@ implementation thlcgjvm(hlcg).g_getarraylen(current_asmdata.CurrAsmList,left.location); thlcgjvm(hlcg).a_load_stack_reg(current_asmdata.CurrAsmList,resultdef,location.register); end +{$ifndef nounsupported} + else if left.resultdef.typ=stringdef then + begin + thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,java_jlobject,0,R_ADDRESSREGISTER); + end +{$endif} else internalerror(2011012004); end; @@ -639,6 +656,12 @@ implementation thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,s32inttype,0,R_INTREGISTER); thlcgjvm(hlcg).g_newarray(current_asmdata.CurrAsmList,target.resultdef,1); end +{$ifndef nounsupported} + else if left.resultdef.typ=stringdef then + begin + thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,java_jlobject,0,R_ADDRESSREGISTER); + end +{$endif} else internalerror(2011031401); thlcgjvm(hlcg).a_load_stack_loc(current_asmdata.CurrAsmList,target.resultdef,target.location); diff --git a/compiler/jvm/njvmld.pas b/compiler/jvm/njvmld.pas index 27044ac14d..d016957511 100644 --- a/compiler/jvm/njvmld.pas +++ b/compiler/jvm/njvmld.pas @@ -66,13 +66,17 @@ function tjvmassignmentnode.pass_1: tnode; } target:=left.actualtargetnode; if (target.nodetype=vecn) and - is_wide_or_unicode_string(tvecnode(target).left.resultdef) then + (is_wide_or_unicode_string(tvecnode(target).left.resultdef) +{$ifndef nounsupported} + or is_ansistring(tvecnode(target).left.resultdef) +{$endif} + ) then begin { prevent errors in case of an expression such as word(str[x]):=1234; } inserttypeconv_explicit(right,cwidechartype); - result:=ccallnode.createintern('fpc_unicodestr_setchar', + result:=ccallnode.createintern('fpc_'+tstringdef(tvecnode(target).left.resultdef).stringtypname+'_setchar', ccallparanode.create(right, ccallparanode.create(tvecnode(target).right, ccallparanode.create(tvecnode(target).left.getcopy,nil)))); diff --git a/compiler/jvmdef.pas b/compiler/jvmdef.pas index d9bc0a27ff..27d87f7230 100644 --- a/compiler/jvmdef.pas +++ b/compiler/jvmdef.pas @@ -90,10 +90,13 @@ implementation st_widestring, st_unicodestring: encodedstr:=encodedstr+'Ljava/lang/String;'; - else {$ifndef nounsupported} - result:=jvmaddencodedtype(java_jlobject,false,encodedstr,founderror); + st_ansistring: + encodedstr:=encodedstr+'Lorg/freepascal/rtl/AnsiString;'; + st_shortstring: + encodedstr:=encodedstr+'Lorg/freepascal/rtl/ShortString;'; {$else} + else { May be handled via wrapping later } result:=false; {$endif} diff --git a/compiler/ncnv.pas b/compiler/ncnv.pas index 7bf323935d..15d68fa529 100644 --- a/compiler/ncnv.pas +++ b/compiler/ncnv.pas @@ -3097,6 +3097,11 @@ implementation newstat : tstatementnode; restemp : ttempcreatenode; begin +{$if defined(jvm) and not defined(nounsupported)} + convtype:=tc_equal; + result:=nil; + exit; +{$endif} { get the correct procedure name } procname := 'fpc_'+tstringdef(left.resultdef).stringtypname+ '_to_'+tstringdef(resultdef).stringtypname; diff --git a/rtl/java/astrings.inc b/rtl/java/astrings.inc new file mode 100644 index 0000000000..e4b269067d --- /dev/null +++ b/rtl/java/astrings.inc @@ -0,0 +1,964 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2000 by Michael Van Canneyt, + member of the Free Pascal development team. + + This file implements AnsiStrings for FPC + + 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. + + **********************************************************************} + +{ This will release some functions for special shortstring support } +{ define EXTRAANSISHORT} + +{ + This file contains the implementation of the AnsiString type, + and all things that are needed for it. + AnsiString is defined as a 'silent' pchar : + a pchar that points to : + + @-8 : SizeInt for reference count; + @-4 : SizeInt for size; + @ : String + Terminating #0; + Pchar(Ansistring) is a valid typecast. + So AS[i] is converted to the address @AS+i-1. + + Constants should be assigned a reference count of -1 + Meaning that they can't be disposed of. +} +(* +Type + PAnsiRec = ^TAnsiRec; + TAnsiRec = Packed Record + Ref, + Len : SizeInt; + First : Char; + end; + +Const + AnsiRecLen = SizeOf(TAnsiRec); + FirstOff = SizeOf(TAnsiRec)-1; +*) + +{**************************************************************************** + Internal functions, not in interface. +****************************************************************************} + + +(* +Function NewAnsiString(Len : SizeInt) : Pointer; +{ + Allocate a new AnsiString on the heap. + initialize it to zero length and reference count 1. +} +Var + P : Pointer; +begin + { request a multiple of 16 because the heap manager alloctes anyways chunks of 16 bytes } + GetMem(P,Len+AnsiRecLen); + If P<>Nil then + begin + PAnsiRec(P)^.Ref:=1; { Set reference count } + PAnsiRec(P)^.Len:=0; { Initial length } + PAnsiRec(P)^.First:=#0; { Terminating #0 } + inc(p,firstoff); { Points to string now } + end; + NewAnsiString:=P; +end; + + +Procedure DisposeAnsiString(Var S : Pointer); {$IFNDEF VER2_0} Inline; {$ENDIF} +{ + Deallocates a AnsiString From the heap. +} +begin + If S=Nil then + exit; + Dec (S,FirstOff); + FreeMem (S); + S:=Nil; +end; + +{$ifndef FPC_SYSTEM_HAS_ANSISTR_DECR_REF} +Procedure fpc_ansistr_decr_ref (Var S : Pointer); [Public,Alias:'FPC_ANSISTR_DECR_REF']; compilerproc; +{ + Decreases the ReferenceCount of a non constant ansistring; + If the reference count is zero, deallocate the string; +} +Type + pSizeInt = ^SizeInt; +Var + l : pSizeInt; +Begin + { Zero string } + If S=Nil then exit; + { check for constant strings ...} + l:=@PAnsiRec(S-FirstOff)^.Ref; + If l^<0 then exit; + { declocked does a MT safe dec and returns true, if the counter is 0 } + If declocked(l^) then + { Ref count dropped to zero } + DisposeAnsiString (S); { Remove...} +end; + +{$endif FPC_SYSTEM_HAS_ANSISTR_DECR_REF} + +{ also define alias for internal use in the system unit } +Procedure fpc_ansistr_decr_ref (Var S : Pointer); [external name 'FPC_ANSISTR_DECR_REF']; + +Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [Public,Alias:'FPC_ANSISTR_INCR_REF']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +Begin + If S=Nil then + exit; + { Let's be paranoid : Constant string ??} + If PAnsiRec(S-FirstOff)^.Ref<0 then exit; + inclocked(PAnsiRec(S-FirstOff)^.Ref); +end; + + +{ also define alias which can be used inside the system unit } +Procedure fpc_AnsiStr_Incr_Ref (S : Pointer); [external name 'FPC_ANSISTR_INCR_REF']; +*) + +Procedure fpc_AnsiStr_Assign (Var DestS : jlobject;S2 : jlobject); compilerproc; +{ + Assigns S2 to S1 (S1:=S2), taking in account reference counts. +} +begin +(* + if DestS=S2 then + exit; + If S2<>nil then + If PAnsiRec(S2-FirstOff)^.Ref>0 then + inclocked(PAnsiRec(S2-FirstOff)^.ref); + { Decrease the reference count on the old S1 } + fpc_ansistr_decr_ref (DestS); + { And finally, have DestS pointing to S2 (or its copy) } + DestS:=S2; +*) +end; +(* +{ alias for internal use } +Procedure fpc_AnsiStr_Assign (Var S1 : Pointer;S2 : Pointer);[external name 'FPC_ANSISTR_ASSIGN']; +*) + +function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): ansistring; compilerproc; +(* +Var + Size,Location : SizeInt; + pc : pchar; +*) +begin +(* + { only assign if s1 or s2 is empty } + if (S1='') then + begin + result:=s2; + exit; + end; + if (S2='') then + begin + result:=s1; + exit; + end; + Location:=Length(S1); + Size:=length(S2); + SetLength(result,Size+Location); + pc:=pchar(result); + Move(S1[1],pc^,Location); + inc(pc,location); + Move(S2[1],pc^,Size+1); +*) +end; + +(* +function fpc_AnsiStr_Concat_multi (const sarr:array of Ansistring): ansistring; compilerproc; +Var + i : Longint; + p : pointer; + pc : pchar; + Size,NewLen : SizeInt; +begin + { First calculate size of the result so we can do + a single call to SetLength() } + NewLen:=0; + for i:=low(sarr) to high(sarr) do + inc(NewLen,length(sarr[i])); + SetLength(result,NewLen); + pc:=pchar(result); + for i:=low(sarr) to high(sarr) do + begin + p:=pointer(sarr[i]); + if assigned(p) then + begin + Size:=length(ansistring(p)); + Move(pchar(p)^,pc^,Size+1); + inc(pc,size); + end; + end; +end; +*) + +(* +{$ifndef FPC_STRTOSHORTSTRINGPROC} + +{ the following declaration has exactly the same effect as } +{ procedure fpc_AnsiStr_To_ShortStr (Var S1 : ShortString;S2 : Pointer); } +{ which is what the old helper was, so we don't need an extra implementation } +{ of the old helper (JM) } +function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring;[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; compilerproc; +{ + Converts a AnsiString to a ShortString; +} +Var + Size : SizeInt; +begin + if S2='' then + fpc_AnsiStr_To_ShortStr:='' + else + begin + Size:=Length(S2); + If Size>high_of_res then + Size:=high_of_res; + Move (S2[1],fpc_AnsiStr_To_ShortStr[1],Size); + byte(fpc_AnsiStr_To_ShortStr[0]):=byte(Size); + end; +end; + +{$else FPC_STRTOSHORTSTRINGPROC} + +procedure fpc_AnsiStr_To_ShortStr (out res: shortstring; const S2 : Ansistring);[Public, alias: 'FPC_ANSISTR_TO_SHORTSTR']; compilerproc; +{ + Converts a AnsiString to a ShortString; +} +Var + Size : SizeInt; +begin + if S2='' then + res:='' + else + begin + Size:=Length(S2); + If Size>high(res) then + Size:=high(res); + Move (S2[1],res[1],Size); + byte(res[0]):=byte(Size); + end; +end; + +{$endif FPC_STRTOSHORTSTRINGPROC} + + +Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc; +{ + Converts a ShortString to a AnsiString; +} +Var + Size : SizeInt; +begin + Size:=Length(S2); + Setlength (fpc_ShortStr_To_AnsiStr,Size); + if Size>0 then + Move(S2[1],Pointer(fpc_ShortStr_To_AnsiStr)^,Size); +end; +*) + +Function fpc_Char_To_AnsiStr(const c : Char): AnsiString; compilerproc; +{ + Converts a Char to a AnsiString; +} +begin +(* + Setlength (fpc_Char_To_AnsiStr,1); + PByte(Pointer(fpc_Char_To_AnsiStr))^:=byte(c); + { Terminating Zero } + PByte(Pointer(fpc_Char_To_AnsiStr)+1)^:=0; +*) +end; + +(* +Function fpc_PChar_To_AnsiStr(const p : pchar): ansistring; compilerproc; +Var + L : SizeInt; +begin + if (not assigned(p)) or (p[0]=#0) Then + L := 0 + else + l:=IndexChar(p^,-1,#0); + SetLength(fpc_PChar_To_AnsiStr,L); + if L > 0 then + Move (P[0],Pointer(fpc_PChar_To_AnsiStr)^,L) +end; +*) + + +Function fpc_CharArray_To_AnsiStr(const arr: array of char; zerobased: boolean = true): ansistring; compilerproc; +(* +var + i : SizeInt; +*) +begin +(* + if (zerobased) then + begin + if (arr[0]=#0) Then + i := 0 + else + begin + i:=IndexChar(arr,high(arr)+1,#0); + if i = -1 then + i := high(arr)+1; + end; + end + else + i := high(arr)+1; + SetLength(fpc_CharArray_To_AnsiStr,i); + if i > 0 then + Move (arr[0],Pointer(fpc_CharArray_To_AnsiStr)^,i); +*) +end; + +procedure fpc_ansistr_to_chararray(out res: array of char; const src: ansistring); compilerproc; +(* +var + len: SizeInt; +*) +begin +(* + len := length(src); + if len > length(res) then + len := length(res); +{$r-} + { make sure we don't try to access element 1 of the ansistring if it's nil } + if len > 0 then + move(src[1],res[0],len); + { fpc_big_chararray is defined as array[0..0], see compproc.inc why } + fillchar(res[len],length(res)-len,0); +{$ifdef RangeCheckWasOn} +{$r+} +{$endif} +*) +end; + + +function fpc_ansistr_setchar(const s: AnsiString; const index: longint; const ch: ansichar): AnsiString; compilerproc; +begin +end; + + +Function fpc_AnsiStr_Compare(const S1,S2 : AnsiString): SizeInt; compilerproc; +{ + Compares 2 AnsiStrings; + The result is + <0 if S10 if S1>S2 +} +(* +Var + MaxI,Temp : SizeInt; +*) +begin +(* + if pointer(S1)=pointer(S2) then + begin + result:=0; + exit; + end; + Maxi:=Length(S1); + temp:=Length(S2); + If MaxI>Temp then + MaxI:=Temp; + if MaxI>0 then + begin + result:=CompareByte(S1[1],S2[1],MaxI); + if result=0 then + result:=Length(S1)-Length(S2); + end + else + result:=Length(S1)-Length(S2); +*) +end; + +Function fpc_AnsiStr_Compare_equal(const S1,S2 : AnsiString): SizeInt; compilerproc; +{ + Compares 2 AnsiStrings for equality/inequality only; + The result is + 0 if S1=S2 + <>0 if S1<>S2 +} +(* +Var + MaxI,Temp : SizeInt; +*) +begin +(* + if pointer(S1)=pointer(S2) then + begin + result:=0; + exit; + end; + Maxi:=Length(S1); + temp:=Length(S2); + Result := Maxi - temp; + if Result = 0 then + if MaxI>0 then + result:=CompareByte(S1[1],S2[1],MaxI); +*) +end; + + + +Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : SizeInt); compilerproc; +{ + Sets The length of string S to L. + Makes sure S is unique, and contains enough room. +} +(* +Var + Temp : Pointer; + lens, lena, + movelen : SizeInt; +*) +begin +(* + if (l>0) then + begin + if Pointer(S)=nil then + begin + GetMem(Pointer(S),AnsiRecLen+L); + PAnsiRec(S)^.Ref:=1; + inc(Pointer(S),firstoff); + end + else if PAnsiRec(Pointer(S)-FirstOff)^.Ref=1 then + begin + Dec(Pointer(S),FirstOff); + lens:=MemSize(Pointer(s)); + lena:=AnsiRecLen+L; + { allow shrinking string if that saves at least half of current size } + if (lena>lens) or ((lens>32) and (lena<=(lens div 2))) then + reallocmem(pointer(S),AnsiRecLen+L); + Inc(Pointer(S),FirstOff); + end + else + begin + { Reallocation is needed... } + Temp:=Pointer(NewAnsiString(L)); + + { also move terminating null } + lens:=succ(length(s)); + if l < lens then + movelen := l + else + movelen := lens; + Move(Pointer(S)^,Temp^,movelen); + { ref count dropped to zero in the mean time? } + If (PAnsiRec(Pointer(S)-FirstOff)^.Ref > 0) and + declocked(PAnsiRec(Pointer(S)-FirstOff)^.Ref) then + freemem(PAnsiRec(Pointer(s)-FirstOff)); + Pointer(S):=Temp; + end; + { Force nil termination in case it gets shorter } + PByte(Pointer(S)+l)^:=0; + PAnsiRec(Pointer(S)-FirstOff)^.Len:=l; + end + else + begin + { Length=0 } + if Pointer(S)<>nil then + fpc_ansistr_decr_ref (Pointer(S)); + Pointer(S):=Nil; + end; +*) +end; + +{***************************************************************************** + Public functions, In interface. +*****************************************************************************} +(* +function fpc_truely_ansistr_unique(Var S : Pointer): Pointer; +Var + SNew : Pointer; + L : SizeInt; +begin + L:=PAnsiRec(Pointer(S)-FirstOff)^.len; + SNew:=NewAnsiString (L); + Move (Pointer(S)^,SNew^,L+1); + PAnsiRec(SNew-FirstOff)^.len:=L; + fpc_ansistr_decr_ref (Pointer(S)); { Thread safe } + pointer(S):=SNew; + pointer(result):=SNew; +end; +*) + +{$ifndef FPC_SYSTEM_HAS_ANSISTR_UNIQUE} +// MV: inline the basic checks for case that S is already unique. +// Rest is too complex to inline, so factor that out as a call. +Function fpc_ansistr_Unique(Var S : jlobject): jlobject; compilerproc; +{ + Make sure reference count of S is 1, + using copy-on-write semantics. +} +begin +(* + pointer(result) := pointer(s); + If Pointer(S)=Nil then + exit; + if PAnsiRec(Pointer(S)-Firstoff)^.Ref<>1 then + result:=fpc_truely_ansistr_unique(s); +*) +end; +{$endif FPC_SYSTEM_HAS_ANSISTR_UNIQUE} + + +Procedure fpc_ansistr_append_char(Var S : AnsiString;c : char); compilerproc; +begin +(* + SetLength(S,length(S)+1); + // avoid unique call + PChar(Pointer(S)+length(S)-1)^:=c; + PByte(Pointer(S)+length(S))^:=0; { Terminating Zero } +*) +end; + +Procedure fpc_ansistr_append_shortstring(Var S : AnsiString;const Str : ShortString); compilerproc; +(* +var + ofs : SizeInt; +*) +begin +(* + if Str='' then + exit; + ofs:=Length(S); + SetLength(S,ofs+length(Str)); + { the pbyte cast avoids an unique call which isn't necessary because SetLength was just called } + move(Str[1],(pointer(S)+ofs)^,length(Str)); + PByte(Pointer(S)+length(S))^:=0; { Terminating Zero } +*) +end; + +Procedure fpc_ansistr_append_ansistring(Var S : AnsiString;const Str : AnsiString); compilerproc; +(* +var + ofs, strlength: SizeInt; + samestring: boolean; +*) +begin +(* + if Str='' then + exit; + samestring := pointer(s) = pointer(str); + { needed in case s and str are the same string } + strlength := length(str); + ofs:=Length(S); + SetLength(S,ofs+strlength); + { the pbyte cast avoids an unique call which isn't necessary because SetLength was just called } + if not(samestring) then + move(Str[1],(pointer(S)+ofs)^,strlength+1) + else + { the setlength may have relocated the string, so str may no longer be valid } + move(S[1],(pointer(S)+ofs)^,strlength+1) +*) +end; + +Function Fpc_Ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiString;compilerproc; +(* +var + ResultAddress : Pointer; +*) +begin +(* + ResultAddress:=Nil; + dec(index); + if Index < 0 then + Index := 0; + { Check Size. Accounts for Zero-length S, the double check is needed because + Size can be maxint and will get <0 when adding index } + if (Size>Length(S)) or + (Index+Size>Length(S)) then + Size:=Length(S)-Index; + If Size>0 then + begin + If Index<0 Then + Index:=0; + ResultAddress:=Pointer(NewAnsiString (Size)); + if ResultAddress<>Nil then + begin + Move (Pointer(Pointer(S)+index)^,ResultAddress^,Size); + PAnsiRec(ResultAddress-FirstOff)^.Len:=Size; + PByte(ResultAddress+Size)^:=0; + end; + end; + fpc_ansistr_decr_ref(Pointer(fpc_ansistr_copy)); + Pointer(fpc_ansistr_Copy):=ResultAddress; +*) +end; + +Function Pos (Const Substr : ShortString; Const Source : AnsiString) : SizeInt; +(* +var + i,MaxLen : SizeInt; + pc : pchar; +*) +begin +(* + Pos:=0; + if Length(SubStr)>0 then + begin + MaxLen:=Length(source)-Length(SubStr); + i:=0; + pc:=@source[1]; + while (i<=MaxLen) do + begin + inc(i); + if (SubStr[1]=pc^) and + (CompareByte(Substr[1],pc^,Length(SubStr))=0) then + begin + Pos:=i; + exit; + end; + inc(pc); + end; + end; +*) +end; + + +Function Pos (Const Substr : AnsiString; Const Source : AnsiString) : SizeInt; +(* +var + i,MaxLen : SizeInt; + pc : pchar; +*) +begin +(* + Pos:=0; + if Length(SubStr)>0 then + begin + MaxLen:=Length(source)-Length(SubStr); + i:=0; + pc:=@source[1]; + while (i<=MaxLen) do + begin + inc(i); + if (SubStr[1]=pc^) and + (CompareByte(Substr[1],pc^,Length(SubStr))=0) then + begin + Pos:=i; + exit; + end; + inc(pc); + end; + end; +*) +end; + + +{ Faster version for a char alone. Must be implemented because } +{ pos(c: char; const s: shortstring) also exists, so otherwise } +{ using pos(char,pchar) will always call the shortstring version } +{ (exact match for first argument), also with $h+ (JM) } +Function Pos (c : Char; Const s : AnsiString) : SizeInt; +(* +var + i: SizeInt; + pc : pchar; +*) +begin +(* + pc:=@s[1]; + for i:=1 to length(s) do + begin + if pc^=c then + begin + pos:=i; + exit; + end; + inc(pc); + end; + pos:=0; +*) +end; + +(* +{$ifndef FPUNONE} +Function fpc_Val_Real_AnsiStr(Const S : AnsiString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_ANSISTR']; compilerproc; +Var + SS : String; +begin + fpc_Val_Real_AnsiStr := 0; + if length(S) > 255 then + code := 256 + else + begin + SS := S; + Val(SS,fpc_Val_Real_AnsiStr,code); + end; +end; +{$endif} + + +Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_ANSISTR']; compilerproc; +Var + SS : String; +begin + if length(S) > 255 then + begin + fpc_Val_Currency_AnsiStr := 0; + code := 256; + end + else + begin + SS := S; + Val(SS,fpc_Val_Currency_AnsiStr,code); + end; +end; + + +Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_ANSISTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_UInt_AnsiStr := 0; + if length(S) > 255 then + code := 256 + else + begin + SS := S; + Val(SS,fpc_Val_UInt_AnsiStr,code); + end; +end; + + +Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_ANSISTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_SInt_AnsiStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := S; + fpc_Val_SInt_AnsiStr := int_Val_SInt_ShortStr(DestSize,SS,Code); + end; +end; + + +{$ifndef CPU64} + +Function fpc_Val_qword_AnsiStr (Const S : AnsiString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_ANSISTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_qword_AnsiStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := S; + Val(SS,fpc_Val_qword_AnsiStr,Code); + end; +end; + + +Function fpc_Val_int64_AnsiStr (Const S : AnsiString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_ANSISTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_int64_AnsiStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := s; + Val(SS,fpc_Val_int64_AnsiStr,Code); + end; +end; + +{$endif CPU64} + + +{$ifndef FPUNONE} +procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : ansistring);[public,alias:'FPC_ANSISTR_FLOAT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +var + ss: ShortString; +begin + str_real(len,fr,d,treal_type(rt),ss); + s:=ss; +end; +{$endif} + +procedure fpc_ansistr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:ansistring);[public,alias:'FPC_ANSISTR_ENUM'];compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} + +var ss:shortstring; + +begin + fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss); + s:=ss; +end; + + +procedure fpc_ansistr_bool(b : boolean;len:sizeint;out s:ansistring);[public,alias:'FPC_ANSISTR_BOOL'];compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +var + ss:shortstring; +begin + fpc_shortstr_bool(b,len,ss); + s:=ss; +end; + + +function fpc_val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:valsint):longint; [public, alias:'FPC_VAL_ENUM_ANSISTR']; compilerproc; + +begin + fpc_val_enum_ansistr:=fpc_val_enum_shortstr(str2ordindex,s,code); +end; + + +{$ifdef FPC_HAS_STR_CURRENCY} +procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring);[public,alias:'FPC_ANSISTR_CURRENCY']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +var + ss: ShortString; +begin + str(c:len:fr,ss); + s:=ss; +end; +{$endif FPC_HAS_STR_CURRENCY} + +Procedure fpc_AnsiStr_UInt(v : ValUInt;Len : SizeInt; out S : AnsiString);[Public,Alias : 'FPC_ANSISTR_VALUINT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +Var + SS : ShortString; +begin + str(v:Len,SS); + S:=SS; +end; + + + +Procedure fpc_AnsiStr_SInt(v : ValSInt;Len : SizeInt; out S : AnsiString);[Public,Alias : 'FPC_ANSISTR_VALSINT']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +Var + SS : ShortString; +begin + str (v:Len,SS); + S:=SS; +end; + + +{$ifndef CPU64} + +Procedure fpc_AnsiStr_QWord(v : QWord;Len : SizeInt; out S : AnsiString);[Public,Alias : 'FPC_ANSISTR_QWORD']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +Var + SS : ShortString; +begin + str(v:Len,SS); + S:=SS; +end; + +Procedure fpc_AnsiStr_Int64(v : Int64; Len : SizeInt; out S : AnsiString);[Public,Alias : 'FPC_ANSISTR_INT64']; compilerproc; {$IFNDEF VER2_0} Inline; {$ENDIF} +Var + SS : ShortString; +begin + str (v:Len,SS); + S:=SS; +end; + +{$endif CPU64} + +Procedure Delete (Var S : AnsiString; Index,Size: SizeInt); +Var + LS : SizeInt; +begin + ls:=Length(S); + If (Index>LS) or (Index<=0) or (Size<=0) then + exit; + UniqueString (S); + If (Size>LS-Index) then // Size+Index gives overflow ?? + Size:=LS-Index+1; + If (Size<=LS-Index) then + begin + Dec(Index); + Move(PByte(Pointer(S))[Index+Size],PByte(Pointer(S))[Index],LS-Index-Size+1); + end; + Setlength(S,LS-Size); +end; + + +Procedure Insert (Const Source : AnsiString; Var S : AnsiString; Index : SizeInt); +var + Temp : AnsiString; + LS : SizeInt; +begin + If Length(Source)=0 then + exit; + if index <= 0 then + index := 1; + Ls:=Length(S); + if index > LS then + index := LS+1; + Dec(Index); + Pointer(Temp) := NewAnsiString(Length(Source)+LS); + SetLength(Temp,Length(Source)+LS); + If Index>0 then + move (Pointer(S)^,Pointer(Temp)^,Index); + Move (Pointer(Source)^,PByte(Temp)[Index],Length(Source)); + If (LS-Index)>0 then + Move(PByte(Pointer(S))[Index],PByte(temp)[Length(Source)+index],LS-Index); + S:=Temp; +end; + + +Function StringOfChar(c : char;l : SizeInt) : AnsiString; +begin + SetLength(StringOfChar,l); + FillChar(Pointer(StringOfChar)^,Length(StringOfChar),c); +end; +Procedure SetString (Out S : AnsiString; Buf : PChar; Len : SizeInt); {$IFNDEF VER2_0} Inline; {$ENDIF} +begin + SetLength(S,Len); + If (Buf<>Nil) then + Move (Buf^,Pointer(S)^,Len); +end; + +Procedure SetString (Out S : AnsiString; Buf : PWideChar; Len : SizeInt); +begin + if (Buf<>nil) and (Len>0) then + widestringmanager.Wide2AnsiMoveProc(Buf,S,Len) + else + SetLength(S, Len); +end; +*) + +function upcase(const s : ansistring) : ansistring; +(* +var + i : SizeInt; +*) +begin +(* + Setlength(result,length(s)); + for i := 1 to length (s) do + result[i] := upcase(s[i]); +*) +end; + + +function lowercase(const s : ansistring) : ansistring; +(* +var + i : SizeInt; +*) +begin +(* + Setlength(result,length(s)); + for i := 1 to length (s) do + result[i] := lowercase(s[i]); +*) +end; + diff --git a/rtl/java/compproc.inc b/rtl/java/compproc.inc index a491d09289..60e0f28ad1 100644 --- a/rtl/java/compproc.inc +++ b/rtl/java/compproc.inc @@ -230,17 +230,29 @@ Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): {$ifdef FPC_HAS_FEATURE_ANSISTRINGS} Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc; Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc; -Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc; +*) +{$ifndef nounsupported} +Procedure fpc_AnsiStr_Assign (Var DestS : jlobject;S2 : jlobject); compilerproc; +{$endif} +(* {$ifdef STR_CONCAT_PROCS} Procedure fpc_AnsiStr_Concat (Var DestS : Ansistring;const S1,S2 : AnsiString); compilerproc; Procedure fpc_AnsiStr_Concat_multi (Var DestS : Ansistring;const sarr:array of Ansistring); compilerproc; {$else STR_CONCAT_PROCS} +*) +{$ifndef nounsupported} function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): AnsiString; compilerproc; +{$endif} +(* function fpc_AnsiStr_Concat_multi (const sarr:array of Ansistring): ansistring; compilerproc; {$endif STR_CONCAT_PROCS} +*) +{$ifndef nounsupported} Procedure fpc_ansistr_append_char(Var S : AnsiString;c : AnsiChar); compilerproc; Procedure fpc_ansistr_append_shortstring(Var S : AnsiString;const Str : ShortString); compilerproc; Procedure fpc_ansistr_append_ansistring(Var S : AnsiString;const Str : AnsiString); compilerproc; +{$endif} +(* {$ifdef EXTRAANSISHORT} Procedure fpc_AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString); compilerproc; {$endif EXTRAANSISHORT} @@ -250,31 +262,34 @@ function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): s procedure fpc_AnsiStr_To_ShortStr (out res : shortstring;const S2 : Ansistring); compilerproc; {$endif FPC_STRTOSHORTSTRINGPROC} Function fpc_ShortStr_To_AnsiStr (Const S2 : ShortString): ansistring; compilerproc; +*) +{$ifndef nounsupported} Function fpc_Char_To_AnsiStr(const c : AnsiChar): AnsiString; compilerproc; - +{$endif} +(* Function fpc_PChar_To_AnsiStr(const p : pchar): ansistring; compilerproc; +*) +{$ifndef nounsupported} Function fpc_CharArray_To_AnsiStr(const arr: array of AnsiChar; zerobased: boolean = true): ansistring; compilerproc; -{$ifndef FPC_STRTOCHARARRAYPROC} -function fpc_ansistr_to_chararray(arraysize: SizeInt; const src: ansistring): fpc_big_chararray; compilerproc; -{$else ndef FPC_STRTOCHARARRAYPROC} procedure fpc_ansistr_to_chararray(out res: array of AnsiChar; const src: ansistring)compilerproc; -{$endif ndef FPC_STRTOCHARARRAYPROC} +function fpc_ansistr_setchar(const s: AnsiString; const index: longint; const ch: ansichar): AnsiString; compilerproc; Function fpc_AnsiStr_Compare(const S1,S2 : AnsiString): SizeInt; compilerproc; Function fpc_AnsiStr_Compare_equal(const S1,S2 : AnsiString): SizeInt; compilerproc; -Procedure fpc_AnsiStr_CheckZero(p : pointer); compilerproc; -Procedure fpc_AnsiStr_CheckRange(len,index : SizeInt); compilerproc; +//Procedure fpc_AnsiStr_CheckZero(p : jlobject); compilerproc; +//Procedure fpc_AnsiStr_CheckRange(len,index : SizeInt); compilerproc; Procedure fpc_AnsiStr_SetLength (Var S : AnsiString; l : SizeInt); compilerproc; Function fpc_ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiString;compilerproc; +{$endif} {$ifdef EXTRAANSISHORT} -Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): SizeInt; compilerproc; +//Function fpc_AnsiStr_ShortStr_Compare (Var S1 : Pointer; Var S2 : ShortString): SizeInt; compilerproc; {$endif EXTRAANSISHORT} { pointer argument because otherwise when calling this, we get an endless loop since a 'var s: ansistring' must be made unique as well } -Function fpc_ansistr_Unique(Var S : Pointer): Pointer; compilerproc; +Function fpc_ansistr_Unique(Var S : jlobject): jlobject; compilerproc; +(* {$endif FPC_HAS_FEATURE_ANSISTRINGS} *) - {***************************************************************************** Unicode string support *****************************************************************************} @@ -287,9 +302,9 @@ function fpc_UnicodeStr_To_ShortStr (high_of_res: SizeInt;const S2 : UnicodeStri procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : UnicodeString); compilerproc; {$endif FPC_STRTOSHORTSTRINGPROC} Function fpc_ShortStr_To_UnicodeStr (Const S2 : ShortString): UnicodeString; compilerproc; +*) Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc; Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compilerproc; -*) Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc; Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc; Function fpc_UnicodeStr_Concat (const S1,S2 : UnicodeString) : UnicodeString; compilerproc; @@ -319,8 +334,10 @@ Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: {$else FPC_STRTOSHORTSTRINGPROC} procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc; {$endif FPC_STRTOSHORTSTRINGPROC} -Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc; *) +{$ifndef nounsupported} +Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc; +{$endif} Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc; Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc; (* @@ -329,8 +346,10 @@ Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortStrin Function fpc_ansistr_to_widechararray(arraysize: SizeInt; const src: AnsiString): fpc_big_widechararray; compilerproc; {$else ndef FPC_STRTOCHARARRAYPROC} procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc; -procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc; *) +{$ifndef nounsupported} +procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc; +{$endif} procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc; (* {$endif ndef FPC_STRTOCHARARRAYPROC} diff --git a/rtl/java/system.pp b/rtl/java/system.pp index 07283adce8..b0f3cffe81 100644 --- a/rtl/java/system.pp +++ b/rtl/java/system.pp @@ -263,6 +263,9 @@ function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_s ********************************************************************** } +{$ifndef nounsupported} +{$i astrings.inc} +{$endif} {$i ustrings.inc} {$i rtti.inc} {$i jrec.inc} diff --git a/rtl/java/ustrings.inc b/rtl/java/ustrings.inc index e38788f942..6bef59066a 100644 --- a/rtl/java/ustrings.inc +++ b/rtl/java/ustrings.inc @@ -72,19 +72,23 @@ begin PUnicodeChar(Pointer(fpc_ShortStr_To_UnicodeStr)+Size*sizeof(UnicodeChar))^:=#0; end; end; - +*) Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc; { Converts a UnicodeString to an AnsiString } +{$ifdef nounsupported} Var Size : SizeInt; +{$endif} begin +{$ifdef nounsupported} result:=''; Size:=Length(S2); if Size>0 then widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(S2)),result,Size); +{$endif} end; @@ -92,15 +96,18 @@ Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compi { Converts an AnsiString to a UnicodeString; } +{$ifdef nounsupported} Var Size : SizeInt; +{$endif} begin +{$ifdef nounsupported} result:=''; Size:=Length(S2); if Size>0 then widestringmanager.Ansi2UnicodeMoveProc(PChar(S2),result,Size); +{$endif} end; -*) Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc; begin @@ -509,11 +516,14 @@ begin res:=temp; end; {$endif FPC_STRTOSHORTSTRINGPROC} - +*) Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc; +{$ifdef nounsupported} var i : SizeInt; +{$endif} begin +{$ifdef nounsupported} if (zerobased) then begin i:=IndexWord(arr,high(arr)+1,0); @@ -524,8 +534,8 @@ begin i := high(arr)+1; SetLength(fpc_WideCharArray_To_AnsiStr,i); widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i); +{$endif} end; -*) Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc; var @@ -634,12 +644,15 @@ begin {$r+} {$endif} end; - +*) procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc; +{$ifdef nounsupported} var len: SizeInt; temp: widestring; +{$endif} begin +{$ifdef nounsupported} len := length(src); { make sure we don't dereference src if it can be nil (JM) } if len > 0 then @@ -654,8 +667,9 @@ begin {$ifdef RangeCheckWasOn} {$r+} {$endif} +{$endif} end; - +(* procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc; var len: longint;