paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-06 09:07:59 +02:00
Code Issues Packages Projects Releases Wiki Activity

+ shortstring support for the JVM target (including accessing character 0 as

Browse Source 
the "length byte")

git-svn-id: branches/jvmbackend@18570 -
This commit is contained in:
Jonas Maebe 2011-08-20 08:11:28 +00:00
parent f2d3203bb6
commit 6857dde33e
25 changed files with 1055 additions and 436 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.gitattributes vendored
View File

@ -7364,6 +7364,8 @@ rtl/java/jrech.inc svneol=native#text/plain
rtl/java/objpas.pp 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/system.pp svneol=native#text/plain
rtl/java/ustringh.inc svneol=native#text/plain
rtl/java/ustrings.inc svneol=native#text/plain

68
compiler/jvm/hlcgcpu.pas
View File

@ -76,6 +76,7 @@ uses
procedure a_jmp_always(list : TAsmList;l: tasmlabel); override;
procedure g_concatcopy(list : TAsmList;size: tdef; const source,dest : treference);override;
procedure g_copyshortstring(list : TAsmList;const source,dest : treference;strdef:tstringdef);override;
procedure a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference); override;
procedure a_loadfpu_ref_reg(list: TAsmList; fromsize, tosize: tdef; const ref: treference; reg: tregister); override;
@ -186,6 +187,7 @@ uses
{ concatcopy helpers }
procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
{ generate a call to a routine in the system unit }
procedure g_call_system_proc(list: TAsmList; const procname: string);
@ -256,6 +258,9 @@ implementation
result:=R_INTREGISTER
else
result:=R_ADDRESSREGISTER;
{ shortstrings are implemented via classes }
else if is_shortstring(def) then
result:=R_ADDRESSREGISTER
else
result:=inherited;
end;
@ -636,20 +641,29 @@ implementation
{ all dimensions are removed from the stack, an array reference is
added }
decstack(list,initdim-1);
{ in case of an array of records, initialise }
{ in case of an array of records or shortstrings, initialise }
elemdef:=tarraydef(arrdef).elementdef;
for i:=1 to pred(initdim) do
elemdef:=tarraydef(elemdef).elementdef;
if elemdef.typ=recorddef then
if (elemdef.typ=recorddef) or
is_shortstring(elemdef) then
begin
{ duplicate array reference }
list.concat(taicpu.op_none(a_dup));
incstack(list,1);
a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER);
tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref);
a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false));
g_call_system_proc(list,'fpc_initialize_array_record');
tg.ungettemp(list,recref);
if elemdef.typ=recorddef then
begin
tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref);
a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false));
g_call_system_proc(list,'fpc_initialize_array_record');
tg.ungettemp(list,recref);
end
else
begin
a_load_const_stack(list,u8inttype,tstringdef(elemdef).len,R_INTREGISTER);
g_call_system_proc(list,'fpc_initialize_array_shortstring');
end;
decstack(list,3);
end;
end;
@ -1120,9 +1134,13 @@ implementation
end;
recorddef:
procname:='FPC_COPY_JRECORD_ARRAY';
floatdef,
stringdef:
floatdef:
procname:='FPC_COPY_SHALLOW_ARRAY';
stringdef:
if is_shortstring(eledef) then
procname:='FPC_COPY_JSHORTSTRING_ARRAY'
else
procname:='FPC_COPY_SHALLOW_ARRAY';
setdef,
variantdef:
begin
@ -1179,6 +1197,27 @@ implementation
end;
procedure thlcgjvm.concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
var
srsym: tsym;
pd: tprocdef;
begin
{ self }
a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
{ result }
a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
{ call fpcDeepCopy helper }
srsym:=search_struct_member(java_shortstring,'FPCDEEPCOPY');
if not assigned(srsym) or
(srsym.typ<>procsym) then
Message1(cg_f_unknown_compilerproc,'ShortstringClass.FpcDeepCopy');
pd:=tprocdef(tprocsym(srsym).procdeflist[0]);
a_call_name(list,pd,pd.mangledname,false);
{ both parameters are removed, no function result }
decstack(list,2);
end;
procedure thlcgjvm.g_concatcopy(list: TAsmList; size: tdef; const source, dest: treference);
var
handled: boolean;
@ -1198,11 +1237,24 @@ implementation
concatcopy_record(list,size,source,dest);
handled:=true;
end;
stringdef:
begin
if is_shortstring(size) then
begin
concatcopy_shortstring(list,size,source,dest);
handled:=true;
end;
end;
end;
if not handled then
inherited;
end;
procedure thlcgjvm.g_copyshortstring(list: TAsmList; const source, dest: treference; strdef: tstringdef);
begin
concatcopy_shortstring(list,strdef,source,dest);
end;
procedure thlcgjvm.a_loadfpu_ref_ref(list: TAsmList; fromsize, tosize: tdef; const ref1, ref2: treference);
var
dstack_slots: longint;

12
compiler/jvm/njvmadd.pas
View File

@ -86,14 +86,15 @@ interface
case nodetype of
addn:
begin
{$ifndef nounsupported}
if is_shortstring(resultdef) then
begin
result:=left;
left:=nil;
result:=inherited;
exit;
end;
{$endif nounsupported}
{ unicode/ansistring operations use functions rather than
procedures for efficiency reasons (were also implemented before
var-parameters were supported; may go to procedures for
maintenance reasons though }
if (left.nodetype=stringconstn) and (tstringconstnode(left).len=0) then
begin
result:=right;
@ -122,9 +123,6 @@ interface
end;
ltn,lten,gtn,gten,equaln,unequaln :
begin
{$ifndef nounsupported}
left.resultdef:=cunicodestringtype;
{$endif nounsupported}
{ call compare routine }
cmpfuncname := 'fpc_'+tstringdef(left.resultdef).stringtypname+'_compare';
{ for equality checks use optimized version }

34
compiler/jvm/njvmcnv.pas
View File

@ -717,6 +717,21 @@ implementation
exit;
end;
{ deal with explicit typecasts between shortstrings and classes (for
ShortstringClass) }
if (is_shortstring(left.resultdef) and
(resultdef.typ=objectdef) and
left.resultdef.is_related(resultdef)) or
((left.resultdef.typ=objectdef) and
is_shortstring(resultdef) and
resultdef.is_related(left.resultdef)) and
(nf_explicit in flags) then
begin
convtype:=tc_equal;
result:=true;
exit;
end;
{$ifndef nounsupported}
{ generated in nmem; replace voidpointertype with java_jlobject }
if nf_load_procvar in flags then
@ -780,6 +795,13 @@ implementation
(def=java_ansistring);
end;
function shortstrcompatible(def: tdef): boolean;
begin
result:=
(def=java_jlobject) or
(def=java_shortstring);
end;
begin
if is_wide_or_unicode_string(todef) then
begin
@ -797,6 +819,14 @@ implementation
begin
result:=ansistrcompatible(todef);
end
else if is_shortstring(todef) then
begin
result:=shortstrcompatible(fromdef)
end
else if is_shortstring(fromdef) then
begin
result:=shortstrcompatible(todef)
end
else
result:=false;
end;
@ -972,7 +1002,9 @@ implementation
else if is_wide_or_unicode_string(checkdef) then
checkdef:=java_jlstring
else if is_ansistring(checkdef) then
checkdef:=java_ansistring;
checkdef:=java_ansistring
else if is_shortstring(checkdef) then
checkdef:=java_shortstring;
if checkdef.typ in [objectdef,recorddef] then
current_asmdata.CurrAsmList.concat(taicpu.op_sym(opcode,current_asmdata.RefAsmSymbol(tabstractrecorddef(checkdef).jvm_full_typename(true))))
else if checkdef.typ=classrefdef then

18
compiler/jvm/njvmcon.pas
View File

@ -68,7 +68,7 @@ implementation
function tjvmstringconstnode.pass_1: tnode;
var
astrclass: tobjectdef;
strclass: tobjectdef;
psym: tsym;
pw: pcompilerwidestring;
begin
@ -89,11 +89,21 @@ implementation
ascii2unicode(value_str,len,pw,false);
ansistringdispose(value_str,len);
pcompilerwidestring(value_str):=pw;
cst_type:=cst_unicodestring;
{ and now add a node to convert the data into ansistring format at
run time }
astrclass:=tobjectdef(search_system_type('ANSISTRINGCLASS').typedef);
psym:=search_struct_member(astrclass,'CREATEFROMLITERALSTRINGBYTES');
case cst_type of
cst_ansistring:
strclass:=tobjectdef(search_system_type('ANSISTRINGCLASS').typedef);
cst_shortstring:
strclass:=tobjectdef(search_system_type('SHORTSTRINGCLASS').typedef);
cst_conststring:
{ used for array of char }
strclass:=tobjectdef(search_system_type('ANSICHARARRAYCLASS').typedef);
else
internalerror(2011052401);
end;
cst_type:=cst_unicodestring;
psym:=search_struct_member(strclass,'CREATEFROMLITERALSTRINGBYTES');
if not assigned(psym) or
(psym.typ<>procsym) then
internalerror(2011052001);

81
compiler/jvm/njvminl.pas
View File

@ -100,9 +100,8 @@ implementation
function tjvminlinenode.typecheck_length(var handled: boolean): tnode;
begin
typecheckpass(left);
if is_dynamic_array(left.resultdef) or
is_open_array(left.resultdef) or
is_wide_or_unicode_string(left.resultdef) then
if is_open_array(left.resultdef) or
is_dynamic_array(left.resultdef) then
begin
resultdef:=s32inttype;
result:=nil;
@ -391,17 +390,25 @@ implementation
end
else
begin
if finaltype<>'R' then
begin
{ expects JLObject }
setlenroutine:='FPC_SETLENGTH_DYNARR_GENERIC';
objarraydef:=java_jlobject;
end
else
begin
{ expects array of FpcBaseRecord}
setlenroutine:='FPC_SETLENGTH_DYNARR_JRECORD';
objarraydef:=search_system_type('TJRECORDARRAY').typedef;
case finaltype of
'R':
begin
{ expects array of FpcBaseRecord}
setlenroutine:='FPC_SETLENGTH_DYNARR_JRECORD';
objarraydef:=search_system_type('TJRECORDARRAY').typedef;
end;
'T':
begin
{ expects array of ShortstringClass}
setlenroutine:='FPC_SETLENGTH_DYNARR_JSHORTSTRING';
objarraydef:=search_system_type('TSHORTSTRINGARRAY').typedef;
end;
else
begin
{ expects JLObject }
setlenroutine:='FPC_SETLENGTH_DYNARR_GENERIC';
objarraydef:=java_jlobject;
end
end;
end;
tcallparanode(newparas).left:=ctypeconvnode.create_explicit(tcallparanode(newparas).left,objarraydef);
@ -476,22 +483,21 @@ implementation
end;
left:=nil;
end
{$ifndef nounsupported}
else if left.resultdef.typ=stringdef then
begin
result:=cnothingnode.create;
end
{$endif}
else
internalerror(2011031405);
end;
function tjvminlinenode.first_setlength: tnode;
begin
{ reverse the parameter order so we can process them more easily }
left:=reverseparameters(tcallparanode(left));
if is_shortstring(left.resultdef) then
begin
left:=reverseparameters(tcallparanode(left));
result:=inherited first_setlength;
exit;
end;
{ treat setlength(x,0) specially: used to init uninitialised locations }
if not assigned(tcallparanode(tcallparanode(left).right).right) and
is_constintnode(tcallparanode(tcallparanode(left).right).left) and
@ -563,12 +569,21 @@ implementation
addstatement(newstatement,ctemprefnode.create(lentemp));
result:=newblock;
end
{$ifndef nounsupported}
else if left.resultdef.typ=stringdef then
else if is_shortstring(left.resultdef) then
begin
result:=nil;
psym:=search_struct_member(tabstractrecorddef(java_shortstring),'LENGTH');
if not assigned(psym) or
(psym.typ<>procsym) then
internalerror(2011052402);
result:=
ccallnode.create(nil,tprocsym(psym),psym.owner,
ctypeconvnode.create_explicit(left,java_shortstring),[]);
{ reused }
left:=nil;
end
{$endif}
{ should be no other string types }
else if left.resultdef.typ=stringdef then
internalerror(2011052403)
else
result:=inherited first_length;
end;
@ -585,14 +600,6 @@ 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
location_reset(location,LOC_REGISTER,OS_S32);
location.register:=hlcg.getintregister(current_asmdata.CurrAsmList,s32inttype);
thlcgjvm(hlcg).a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,0,location.register);
end
{$endif}
else
internalerror(2011012004);
end;
@ -738,17 +745,13 @@ implementation
current_asmdata.CurrAsmList.concat(taicpu.op_string(a_ldc,0,@emptystr));
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
end
else if is_ansistring(target.resultdef) then
thlcgjvm(hlcg).a_load_const_stack(current_asmdata.CurrAsmList,java_jlobject,0,R_ADDRESSREGISTER)
else if is_dynamic_array(target.resultdef) then
begin
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);

26
compiler/jvm/njvmld.pas
View File

@ -53,7 +53,7 @@ uses
verbose,
aasmdata,
nbas,nld,ncal,nmem,ncnv,
symconst,symsym,symdef,defutil,jvmdef,
symconst,symsym,symdef,symtable,defutil,jvmdef,
paramgr,
cgbase,hlcgobj;
@ -62,6 +62,7 @@ uses
function tjvmassignmentnode.pass_1: tnode;
var
target: tnode;
psym: tsym;
begin
{ intercept writes to string elements, because Java strings are immutable
-> detour via StringBuilder
@ -85,6 +86,29 @@ function tjvmassignmentnode.pass_1: tnode;
tvecnode(target).right:=nil;
exit;
end
else if (target.nodetype=vecn) and
is_shortstring(tvecnode(target).left.resultdef) then
begin
{ prevent errors in case of an expression such as
byte(str[x]):=12;
}
inserttypeconv_explicit(right,cchartype);
{ call ShortstringClass(shortstring).setChar(index,char) }
inserttypeconv_explicit(tvecnode(target).left,java_shortstring);
psym:=search_struct_member(tabstractrecorddef(java_shortstring),'SETCHAR');
if not assigned(psym) or
(psym.typ<>procsym) then
internalerror(2011052408);
result:=
ccallnode.create(
ccallparanode.create(right,
ccallparanode.create(tvecnode(target).right,nil)),
tprocsym(psym),psym.owner,tvecnode(target).left,[]);
right:=nil;
tvecnode(target).left:=nil;
tvecnode(target).right:=nil;
exit;
end
else
result:=inherited;
end;

18
compiler/jvm/njvmmem.pas
View File

@ -165,13 +165,19 @@ implementation
psym: tsym;
stringclass: tdef;
begin
if is_wide_or_unicode_string(left.resultdef) or
is_ansistring(left.resultdef) then
if (left.resultdef.typ=stringdef) then
begin
if is_ansistring(left.resultdef) then
stringclass:=java_ansistring
else
stringclass:=java_jlstring;
case tstringdef(left.resultdef).stringtype of
st_ansistring:
stringclass:=java_ansistring;
st_unicodestring,
st_widestring:
stringclass:=java_jlstring;
st_shortstring:
stringclass:=java_shortstring;
else
internalerror(2011052407);
end;
psym:=search_struct_member(tabstractrecorddef(stringclass),'CHARAT');
if not assigned(psym) or
(psym.typ<>procsym) then

21
compiler/jvm/tgcpu.pas
View File

@ -133,13 +133,24 @@ unit tgcpu;
begin
if is_shortstring(def) then
begin
{$ifndef nounsupported}
gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
{ add the maxlen parameter }
thlcgjvm(hlcg).a_load_const_stack(list,u8inttype,tstringdef(def).len,R_INTREGISTER);
{ call the constructor }
sym:=tsym(tobjectdef(java_shortstring).symtable.find('CREATEEMPTY'));
if assigned(sym) and
(sym.typ=procsym) then
begin
if tprocsym(sym).procdeflist.Count<>1 then
internalerror(2011052404);
pd:=tprocdef(tprocsym(sym).procdeflist[0]);
end;
hlcg.a_call_name(list,pd,pd.mangledname,false);
{ static calls method replaces parameter with string instance
-> no change in stack height }
{ store reference to instance }
thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
result:=true;
{$else}
internalerror(2011051701);
{$endif}
end;
end;
end;

8
compiler/jvmdef.pas
View File

@ -197,14 +197,11 @@ implementation
encodedstr:=encodedstr+'Ljava/lang/String;';
st_ansistring:
result:=jvmaddencodedtype(java_ansistring,false,encodedstr,forcesignature,founderror);
{$ifndef nounsupported}
st_shortstring:
encodedstr:=encodedstr+'Lorg/freepascal/rtl/ShortString;';
{$else}
result:=jvmaddencodedtype(java_shortstring,false,encodedstr,forcesignature,founderror);
else
{ May be handled via wrapping later }
result:=false;
{$endif}
end;
end;
enumdef,
@ -453,8 +450,11 @@ implementation
errdef: tdef;
res: string;
begin
{ keep in sync with rtl/java/jdynarrh.inc and usage in njvminl }
if is_record(def) then
result:='R'
else if is_shortstring(def) then
result:='T'
else
begin
if not jvmtryencodetype(def,res,false,errdef) then

7
compiler/ncgcnv.pas
View File

@ -361,13 +361,6 @@ interface
procedure tcgtypeconvnode.second_char_to_string;
begin
{$ifdef jvm}
{$ifndef nounsupported}
location_reset_ref(location,LOC_REFERENCE,OS_NO,1);
tg.gethltemp(current_asmdata.CurrAsmList,cshortstringtype,256,tt_normal,location.reference);
exit;
{$endif nounsupported}
{$endif jvm}
location_reset_ref(location,LOC_REFERENCE,OS_NO,2);
case tstringdef(resultdef).stringtype of
st_shortstring :

27
compiler/ncnv.pas
View File

@ -1091,9 +1091,10 @@ implementation
result:=hp;
end
else
{ shortstrings are handled 'inline' (except for widechars) }
{ shortstrings are handled 'inline' for non-vm targets (except for widechars) }
if (tstringdef(resultdef).stringtype <> st_shortstring) or
(torddef(left.resultdef).ordtype = uwidechar) then
(torddef(left.resultdef).ordtype = uwidechar) or
(target_info.system in systems_managed_vm) then
begin
if (tstringdef(resultdef).stringtype <> st_shortstring) then
begin
@ -1115,7 +1116,11 @@ implementation
newblock:=internalstatements(newstat);
restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false);
addstatement(newstat,restemp);
addstatement(newstat,ccallnode.createintern('fpc_wchar_to_shortstr',ccallparanode.create(left,ccallparanode.create(
if torddef(left.resultdef).ordtype<>uwidechar then
procname := 'fpc_char_to_shortstr'
else
procname := 'fpc_wchar_to_shortstr';
addstatement(newstat,ccallnode.createintern(procname,ccallparanode.create(left,ccallparanode.create(
ctemprefnode.create(restemp),nil))));
addstatement(newstat,ctempdeletenode.create_normal_temp(restemp));
addstatement(newstat,ctemprefnode.create(restemp));
@ -2240,7 +2245,10 @@ implementation
{ perform target-specific explicit typecast
checks }
if target_specific_explicit_typeconv then
exit;
begin
result:=simplify(false);
exit;
end;
end;
end;
end
@ -3115,17 +3123,6 @@ implementation
newstat : tstatementnode;
restemp : ttempcreatenode;
begin
{$if defined(jvm) and not defined(nounsupported)}
if (not is_ansistring(left.resultdef) and
not is_unicodestring(left.resultdef)) or
(not is_ansistring(resultdef) and
not is_unicodestring(resultdef)) then
begin
convtype:=tc_equal;
result:=nil;
exit;
end;
{$endif}
{ get the correct procedure name }
procname := 'fpc_'+tstringdef(left.resultdef).stringtypname+
'_to_'+tstringdef(resultdef).stringtypname;

5
compiler/nld.pas
View File

@ -590,8 +590,9 @@ implementation
{ insert typeconv, except for chars that are handled in
secondpass and except for ansi/wide string that can
be converted immediatly }
if not(is_char(right.resultdef) or
(right.resultdef.typ=stringdef)) then
if (not is_char(right.resultdef) or
(target_info.system in systems_managed_vm)) and
(right.resultdef.typ<>stringdef) then
inserttypeconv(right,left.resultdef);
if right.resultdef.typ=stringdef then
begin

4
compiler/nopt.pas
View File

@ -319,8 +319,12 @@ begin
inserttypeconv(sn,p.resultdef);
if is_shortstr then
begin
{$ifndef jvm}
sn:=caddrnode.create(sn);
include(sn.flags,nf_internal);
{$else not jvm}
inserttypeconv_internal(sn,java_shortstring);
{$endif jvm}
end;
arrp:=carrayconstructornode.create(sn,arrp);
hp:=taddnode(hp).left;

24
compiler/pdecobj.pas
View File

@ -1275,8 +1275,8 @@ implementation
odt_javaclass:
begin
if (current_structdef.objname^='TOBJECT') then
class_tobject:=current_objectdef;
if (current_objectdef.objname^='JLOBJECT') then
class_tobject:=current_objectdef
else if (current_objectdef.objname^='JLOBJECT') then
begin
java_jlobject:=current_objectdef;
{ the methodpointer type is normally created in
@ -1288,15 +1288,17 @@ implementation
hrecst.addfield(fsym,vis_hidden);
methodpointertype:=trecorddef.create('',hrecst);
systemunit.insert(ttypesym.create('$methodpointer',methodpointertype));
end;
if (current_objectdef.objname^='JLTHROWABLE') then
java_jlthrowable:=current_objectdef;
if (current_objectdef.objname^='FPCBASERECORDTYPE') then
java_fpcbaserecordtype:=current_objectdef;
if (current_objectdef.objname^='JLSTRING') then
java_jlstring:=current_objectdef;
if (current_objectdef.objname^='ANSISTRINGCLASS') then
java_ansistring:=current_objectdef;
end
else if (current_objectdef.objname^='JLTHROWABLE') then
java_jlthrowable:=current_objectdef
else if (current_objectdef.objname^='FPCBASERECORDTYPE') then
java_fpcbaserecordtype:=current_objectdef
else if (current_objectdef.objname^='JLSTRING') then
java_jlstring:=current_objectdef
else if (current_objectdef.objname^='ANSISTRINGCLASS') then
java_ansistring:=current_objectdef
else if (current_objectdef.objname^='SHORTSTRINGCLASS') then
java_shortstring:=current_objectdef
end;
end;
end;

29
compiler/symdef.pas
View File

@ -800,6 +800,8 @@ interface
java_jlstring : tobjectdef;
{ FPC java implementation of ansistrings }
java_ansistring : tobjectdef;
{ FPC java implementation of shortstrings }
java_shortstring : tobjectdef;
const
{$ifdef i386}
@ -1613,8 +1615,11 @@ implementation
((d=java_jlobject) or
(d=java_jlstring))) or
((stringtype=st_ansistring) and
(d=java_jlobject) or
(d=java_ansistring)));
((d=java_jlobject) or
(d=java_ansistring))) or
((stringtype=st_shortstring) and
((d=java_jlobject) or
(d=java_shortstring))));
end;
@ -4830,15 +4835,17 @@ implementation
not(oo_is_formal in objectoptions) then
begin
if (objname^='JLOBJECT') then
java_jlobject:=self;
if (objname^='JLTHROWABLE') then
java_jlthrowable:=self;
if (objname^='FPCBASERECORDTYPE') then
java_fpcbaserecordtype:=self;
if (objname^='JLSTRING') then
java_jlstring:=self;
if (objname^='ANSISTRINGCLASS') then
java_ansistring:=self;
java_jlobject:=self
else if (objname^='JLTHROWABLE') then
java_jlthrowable:=self
else if (objname^='FPCBASERECORDTYPE') then
java_fpcbaserecordtype:=self
else if (objname^='JLSTRING') then
java_jlstring:=self
else if (objname^='ANSISTRINGCLASS') then
java_ansistring:=self
else if (objname^='SHORTSTRINGCLASS') then
java_shortstring:=self
end;
writing_class_record_dbginfo:=false;
end;

3
rtl/java/astringh.inc
View File

@ -15,7 +15,6 @@
**********************************************************************}
type
TAnsiCharArray = array of ansichar;
AnsistringClass = class sealed
private
fdata: TAnsiCharArray;
@ -24,11 +23,13 @@ type
constructor Create(const arr: array of unicodechar);overload;
constructor Create(const u: unicodestring);overload;
constructor Create(const a: ansistring);overload;
constructor Create(const s: shortstring);overload;
constructor Create(ch: ansichar);overload;
constructor Create(ch: unicodechar);overload;
class function CreateFromLiteralStringBytes(const u: unicodestring): ansistring; static;
function charAt(index: jint): ansichar;
function toUnicodeString: unicodestring;
function toShortstring(maxlen: byte): shortstring;
function toString: JLString; override;
// function concat(const a: ansistring): ansistring;
// function concatmultiple(const arr: array of ansistring): ansistring;

85
rtl/java/astrings.inc
View File

@ -50,6 +50,12 @@ begin
end;
constructor AnsistringClass.Create(const s: shortstring);
begin
Create(ShortstringClass(s).fdata);
end;
constructor AnsistringClass.Create(ch: ansichar);
begin
setlength(fdata,1);
@ -91,6 +97,12 @@ begin
end;
function AnsistringClass.toShortstring(maxlen: byte): shortstring;
begin
result:=shortstring(ShortstringClass.Create(ansistring(self),maxlen));
end;
function AnsistringClass.toString: JLString;
begin
result:=JLString.Create(TJByteArray(fdata));
@ -191,75 +203,37 @@ procedure fpc_AnsiStr_Concat_multi (var DestS:Ansistring;const sarr:array of Ans
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;
procedure fpc_AnsiStr_To_ShortStr (out res: shortstring; const S2 : Ansistring); 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);
Size:=high(res);
JLSystem.ArrayCopy(JLObject(AnsistringClass(S2).fdata),0,JLObject(ShortstringClass(res).fdata),0,Size);
setlength(res,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);
Setlength (result,Size);
if Size>0 then
Move(S2[1],Pointer(fpc_ShortStr_To_AnsiStr)^,Size);
*)
JLSystem.ArrayCopy(JLObject(ShortstringClass(S2).fdata),0,JLObject(AnsistringClass(result).fdata),0,Size);
end;
@ -320,8 +294,8 @@ begin
exit;
end;
res:=AnsistringClass.Create;
setlength(res.fdata,i);
JLSystem.ArrayCopy(JLObject(@arr),0,JLObject(res.fdata),0,i);
setlength(res.fdata,high(arr)+1);
JLSystem.ArrayCopy(JLObject(@arr),0,JLObject(res.fdata),0,high(arr)+1);
result:=Ansistring(res);
end;
@ -409,12 +383,12 @@ function fpc_AnsiStr_SetLength (S : AnsiString; l : SizeInt): Ansistring; compil
Sets The length of string S to L.
Makes sure S is unique, and contains enough room.
}
Var
lens, lena,
movelen : SizeInt;
begin
setlength(AnsistringClass(s).fdata,l);
result:=s;
if not assigned(AnsistringClass(s)) then
result:=ansistring(AnsistringClass.Create)
else
result:=s;
setlength(AnsistringClass(result).fdata,l);
end;
{*****************************************************************************
@ -465,20 +439,15 @@ begin
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 }
*)
JLSystem.ArrayCopy(JLObject(ShortstringClass(Str).fdata),0,JLObject(AnsistringClass(S).fdata),ofs,length(Str));
end;
Procedure fpc_ansistr_append_ansistring(Var S : AnsiString;const Str : AnsiString); compilerproc;

46
rtl/java/compproc.inc
View File

@ -36,24 +36,16 @@ type
fpc_normal_set_byte = array[0..31] of byte;
fpc_normal_set_long = array[0..7] of longint;
(*
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_shortstr_to_shortstr(len:longint; const sstr: shortstring): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_shortstr_to_shortstr(out res:shortstring; const sstr: shortstring); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$ifndef STR_CONCAT_PROCS}
function fpc_shortstr_concat(const s1,s2:shortstring): shortstring; compilerproc;
{$else STR_CONCAT_PROCS}
procedure fpc_shortstr_concat(var dests:shortstring;const s1,s2:shortstring);compilerproc;
procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of pshortstring);compilerproc;
{$endif STR_CONCAT_PROCS}
procedure fpc_shortstr_concat_multi(var dests:shortstring;const sarr:array of ShortstringClass);compilerproc;
procedure fpc_shortstr_append_shortstr(var s1:shortstring;const s2:shortstring); compilerproc;
function fpc_shortstr_compare(const left,right:shortstring) : longint; compilerproc;
function fpc_shortstr_compare_equal(const left,right:shortstring) : longint; compilerproc;
(*
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_pchar_to_shortstr(p:pchar):shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
@ -62,21 +54,14 @@ procedure fpc_pchar_to_shortstr(out res : shortstring;p:pchar); compilerproc;
function fpc_pchar_length(p:pchar):longint; compilerproc;
function fpc_pwidechar_length(p:pwidechar):longint; compilerproc;
*)
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_chararray_to_shortstr(const arr: array of AnsiChar; zerobased: boolean = true):shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_chararray_to_shortstr(out res : shortstring;const arr: array of AnsiChar; zerobased: boolean = true); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$ifndef FPC_STRTOCHARARRAYPROC}
function fpc_shortstr_to_chararray(arraysize: longint; const src: ShortString): fpc_big_chararray; compilerproc;
{$else ndef FPC_STRTOCHARARRAYPROC}
procedure fpc_shortstr_to_chararray(out res: array of AnsiChar; const src: ShortString); compilerproc;
{$endif ndef FPC_STRTOCHARARRAYPROC}
Function fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc;
function fpc_char_copy(c:AnsiChar;index : SizeInt;count : SizeInt): shortstring;compilerproc;
*)
(*
{ Str() support }
procedure fpc_ShortStr_sint(v : valsint;len : SizeInt;out s : shortstring); compilerproc;
@ -296,15 +281,8 @@ Function fpc_ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiSt
Unicode string support
*****************************************************************************}
(*
{$ifndef VER2_2}
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_UnicodeStr_To_ShortStr (high_of_res: SizeInt;const S2 : UnicodeString): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
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;
*)
procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : 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;
@ -330,32 +308,24 @@ procedure fpc_UnicodeCharArray_To_ShortStr(out res : shortstring;const arr: arra
Function fpc_UnicodeCharArray_To_AnsiStr(const arr: array of unicodechar; zerobased: boolean = true): AnsiString; compilerproc;
*)
Function fpc_UnicodeCharArray_To_UnicodeStr(const arr: array of unicodechar; zerobased: boolean = true): UnicodeString; compilerproc;
(*
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
*)
{$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_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;
(*
{$ifndef FPC_STRTOCHARARRAYPROC}
Function fpc_shortstr_to_widechararray(arraysize: SizeInt; const src: ShortString): fpc_big_widechararray; compilerproc;
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;
*)
{$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}
*)
Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt; compilerproc;
Function fpc_UnicodeStr_Compare_equal(const S1,S2 : UnicodeString): SizeInt; compilerproc;
(*
@ -369,11 +339,11 @@ Function fpc_Char_To_UChar(const c : AnsiChar): UnicodeChar; compilerproc;
Function fpc_UChar_To_Char(const c : UnicodeChar): AnsiChar; compilerproc;
Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
Function fpc_WChar_To_UnicodeStr(const c : WideChar): UnicodeString; compilerproc;
(*
Function fpc_UChar_To_AnsiStr(const c : UnicodeChar): AnsiString; compilerproc;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_Char_To_ShortStr(out res : shortstring;const c : AnsiChar) compilerproc;
procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
@ -388,7 +358,6 @@ Function fpc_PUnicodeChar_To_ShortStr(const p : punicodechar): shortstring; comp
procedure fpc_PUnicodeChar_To_ShortStr(out res : shortstring;const p : punicodechar); compilerproc;
{$endif FPC_STRTOSHORTSTRINGPROC}
{$endif FPC_HAS_FEATURE_WIDESTRINGS}
*)
(*
{$ifdef FPC_HAS_FEATURE_WIDESTRINGS}
@ -658,6 +627,7 @@ procedure fpc_initialize_array_unicodestring(arr: TJObjectArray; normalarrdim: l
level elements types of the array) }
procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc;
procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType);compilerproc;
procedure fpc_initialize_array_shortstring(arr: TJObjectArray; normalarrdim: longint; maxlen: byte);compilerproc;
(*
{$ifdef FPC_SETBASE_USED}

4
rtl/java/jdynarrh.inc
View File

@ -25,6 +25,7 @@ type
TJDoubleArray = array of jdouble;
TJObjectArray = array of JLObject;
TJRecordArray = array of FpcBaseRecordType;
TShortstringArray = array of ShortstringClass;
TJStringArray = array of unicodestring;
const
@ -37,6 +38,7 @@ const
FPCJDynArrTypeJDouble = 'D';
FPCJDynArrTypeJObject = 'A';
FPCJDynArrTypeRecord = 'R';
FPCJDynArrTypeShortstring = 'T';
{ 1-dimensional setlength routines
@ -46,11 +48,13 @@ const
}
function fpc_setlength_dynarr_generic(aorg, anew: JLObject; deepcopy: boolean; docopy: boolean = true): JLObject;
function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boolean): TJRecordArray;
function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray;
{ array copying helpers }
procedure fpc_copy_shallow_array(src, dst: JLObject; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
{ multi-dimendional setlength routine: all intermediate dimensions are arrays
of arrays, so that's the same for all array kinds. Only the type of the final

19
rtl/java/rtti.inc
View File

@ -86,3 +86,22 @@ procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint;
end;
end;
procedure fpc_initialize_array_shortstring_intern(arr: TJObjectArray; normalarrdim: longint; maxlen: byte); external name 'fpc_initialize_array_shortstring';
procedure fpc_initialize_array_shortstring(arr: TJObjectArray; normalarrdim: longint; maxlen: byte);compilerproc;
var
i: longint;
begin
if normalarrdim > 0 then
begin
for i:=low(arr) to high(arr) do
fpc_initialize_array_shortstring_intern(TJObjectArray(arr[i]),normalarrdim-1,maxlen);
end
else
begin
for i:=low(arr) to high(arr) do
arr[i]:=ShortstringClass.CreateEmpty(maxlen);
end;
end;

108
rtl/java/sstringh.inc Normal file
View File

@ -0,0 +1,108 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2005 by Florian Klaempfl,
member of the Free Pascal development team.
This file implements support routines for Shortstrings with FPC/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.
**********************************************************************}
type
TAnsiCharArray = array of ansichar;
ShortstringClass = class sealed (JLCloneable)
public
{ "length byte" }
curlen: byte;
{ length is always the maximum length of the string (so that even reads
past the current length of the shortstring work, just like in regular
shortstrings }
fdata: TAnsiCharArray;
public
constructor Create(const arr: array of ansichar; maxlen: byte);overload;
constructor Create(const arr: array of unicodechar; maxlen: byte);overload;
constructor Create(const u: unicodestring; maxlen: byte);overload;
constructor Create(const a: ansistring; maxlen: byte);overload;
constructor Create(const s: shortstring; maxlen: byte);overload;
constructor Create(ch: ansichar; maxlen: byte);overload;
constructor Create(ch: unicodechar; maxlen: byte);overload;
class function CreateEmpty(maxlen: byte): ShortstringClass; static;
class function CreateFromLiteralStringBytes(const u: unicodestring): shortstring; static;
procedure FpcDeepCopy(dest: ShortstringClass);
procedure setChar(index: jint; char: ansichar);
function charAt(index: jint): ansichar;
function toUnicodeString: unicodestring;
function toAnsistring: ansistring;
function toString: JLString; override;
function clone: JLObject; override;
// function concat(const a: shortstring): shortstring;
// function concatmultiple(const arr: array of shortstring): shortstring;
function length: jint;
end;
AnsiCharArrayClass = class sealed
class function CreateFromLiteralStringBytes(const u: unicodestring; maxlen: byte): TAnsiCharArray; static;
end;
//Function Pos (Const Substr : Ansistring; Const Source : Ansistring) : SizeInt;
//Function Pos (c : AnsiChar; Const s : Ansistring) : SizeInt;
//Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;
//Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;
//Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;
Function Pos (c : AnsiChar; Const s : Shortstring) : SizeInt;
Function Pos (const substr : ShortString; Const source : Shortstring) : SizeInt;
//Function Pos (c : char; Const s : UnicodeString) : SizeInt;
Function UpCase(const s : shortstring) : shortstring;
Function LowerCase(const s : shortstring) : shortstring;
//Function UpCase(c:UnicodeChar):UnicodeChar;
//Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt);
//Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt);
//Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt);
//Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt);
//
//function WideCharToString(S : PWideChar) : AnsiString;
//function StringToWideChar(const Src : AnsiString;Dest : PWideChar;DestSize : SizeInt) : PWideChar;
//function WideCharLenToString(S : PWideChar;Len : SizeInt) : AnsiString;
//procedure WideCharLenToStrVar(Src : PWideChar;Len : SizeInt;out Dest : AnsiString);
//procedure WideCharToStrVar(S : PWideChar;out Dest : AnsiString);
//
//function UnicodeCharToString(S : PUnicodeChar) : AnsiString;
//function StringToUnicodeChar(const Src : AnsiString;Dest : PUnicodeChar;DestSize : SizeInt) : PUnicodeChar;
//function UnicodeCharLenToString(S : PUnicodeChar;Len : SizeInt) : AnsiString;
//procedure UnicodeCharLenToStrVar(Src : PUnicodeChar;Len : SizeInt;out Dest : AnsiString);
//procedure UnicodeCharToStrVar(S : PUnicodeChar;out Dest : AnsiString);
//
//procedure DefaultUnicode2AnsiMove(source:punicodechar;var dest:ansistring;len:SizeInt);
//procedure DefaultAnsi2UnicodeMove(source:pchar;var dest:unicodestring;len:SizeInt);
//function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
//function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt;
//function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif}
//function Utf8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt;
//function UTF8Encode(const s : Ansistring) : UTF8String; inline;
//function UTF8Encode(const s : UnicodeString) : UTF8String;
//function UTF8Decode(const s : UTF8String): UnicodeString;
//function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif}
//function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif}
//function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String;
//function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString;
//function WideStringToUCS4String(const s : WideString) : UCS4String;
//function UCS4StringToWideString(const s : UCS4String) : WideString;
//Procedure GetWideStringManager (Var Manager : TUnicodeStringManager);
//Procedure SetWideStringManager (Const New : TUnicodeStringManager);
//Procedure SetWideStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);
//Procedure GetUnicodeStringManager (Var Manager : TUnicodeStringManager);
//Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager);
//Procedure SetUnicodeStringManager (Const New : TUnicodeStringManager; Var Old: TUnicodeStringManager);

507
rtl/java/sstrings.inc Normal file
View File

@ -0,0 +1,507 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 1999-2005, 2011 by Florian Klaempfl, Jonas Maebe
members of the Free Pascal development team.
This file implements support routines for Shortstrings with FPC/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.
**********************************************************************}
constructor ShortstringClass.Create(const arr: array of ansichar; maxlen: byte);
begin
setlength(fdata,maxlen);
if high(arr)=-1 then
exit;
curlen:=min(high(arr)+1,maxlen);
JLSystem.ArrayCopy(JLObject(@arr),0,JLObject(fdata),0,curlen);
end;
constructor ShortstringClass.Create(const arr: array of unicodechar; maxlen: byte);
begin
if high(arr)=-1 then
begin
setlength(fdata,maxlen);
exit;
end;
fdata:=TAnsiCharArray(JLString.Create(arr).getBytes);
setlength(fdata,maxlen);
curlen:=min(high(fdata)+1,maxlen);
end;
constructor ShortstringClass.Create(const u: unicodestring; maxlen: byte);
begin
if system.length(u)=0 then
begin
setlength(fdata,maxlen);
exit;
end;
fdata:=TAnsiCharArray(JLString(u).getBytes);
setlength(fdata,maxlen);
curlen:=min(high(fdata)+1,maxlen);
end;
constructor ShortstringClass.Create(const a: ansistring; maxlen: byte);
var
alen: jint;
begin
setlength(fdata,maxlen);
alen:=system.length(a);
if alen=0 then
exit;
curlen:=min(alen,maxlen);
JLSystem.ArrayCopy(JLObject(AnsistringClass(a).fdata),0,JLObject(fdata),0,curlen);
end;
constructor ShortstringClass.Create(const s: shortstring; maxlen: byte);overload;
begin
setlength(fdata,maxlen);
if system.length(s)=0 then
exit;
curlen:=min(system.length(s),maxlen);
JLSystem.ArrayCopy(JLObject(ShortstringClass(s).fdata),0,JLObject(fdata),0,min(system.length(s),maxlen));
end;
constructor ShortstringClass.Create(ch: ansichar; maxlen: byte);overload;
begin
setlength(fdata,maxlen);
fdata[0]:=ch;
curlen:=1;
end;
constructor ShortstringClass.Create(ch: unicodechar; maxlen: byte);overload;
begin
fdata:=TAnsiCharArray(JLString.Create(ch).getBytes);
curlen:=min(system.length(fdata),maxlen);
setlength(fdata,maxlen);
end;
class function ShortstringClass.CreateEmpty(maxlen: byte): ShortstringClass;
begin
result:=ShortstringClass.Create;
setlength(result.fdata,maxlen);
end;
class function ShortstringClass.CreateFromLiteralStringBytes(const u: unicodestring): shortstring;
var
i: longint;
begin
{ used to construct constant shortstrings from Java string constants }
ShortstringClass(result).curlen:=min(system.length(u),255);
setlength(ShortstringClass(result).fdata,ShortstringClass(result).curlen);
for i:=1 to ShortstringClass(result).curlen do
ShortstringClass(result).fdata[i-1]:=ansichar(ord(u[i]));
end;
procedure ShortstringClass.FpcDeepCopy(dest: ShortstringClass);
begin
{ should only be called for shortstrings of the same maximum length }
dest.curlen:=curlen;
JLSystem.ArrayCopy(JLObject(fdata),0,JLObject(dest.fdata),0,system.length(fdata));
end;
procedure ShortstringClass.setChar(index: jint; char: ansichar);
begin
{ index is 1-based here }
{ support accessing the length byte }
if index=0 then
curlen:=ord(char)
else
fdata[index-1]:=char;
end;
function ShortstringClass.charAt(index: jint): ansichar;
begin
{ index is already decreased by one, because same calling code is used for
JLString.charAt() }
{ support accessing the length byte }
if (index=-1) then
result:=ansichar(curlen)
else
result:=fdata[index];
end;
function ShortstringClass.toUnicodeString: unicodestring;
begin
result:=UnicodeString(JLString.Create(TJByteArray(fdata)));
end;
function ShortstringClass.toAnsistring: ansistring;
begin
result:=ansistring(AnsistringClass.Create(shortstring(self)));
end;
function ShortstringClass.toString: JLString;
begin
if curlen<>0 then
result:=JLString.Create(TJByteArray(fdata),0,curlen-1)
else
result:='';
end;
function ShortstringClass.clone: JLObject;
begin
result:=ShortstringClass.Create(Shortstring(self),system.length(fdata));
end;
function ShortstringClass.length: jint;
begin
result:=curlen;
end;
class function AnsiCharArrayClass.CreateFromLiteralStringBytes(const u: unicodestring; maxlen: byte): TAnsiCharArray;
var
i: longint;
begin
{ used to construct constant chararrays from Java string constants }
setlength(result,system.length(u));
for i:=1 to system.length(u) do
result[i-1]:=ansichar(ord(u[i]));
end;
procedure fpc_Shortstr_SetLength(var s:shortstring;len:SizeInt); compilerproc;
begin
if len>255 then
len:=255;
ShortstringClass(s).curlen:=len;
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);
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;
}
begin
setlength(res,1);
ShortstringClass(res).fdata[0]:=c;
end;
Function fpc_shortstr_Copy(const s:shortstring;index:SizeInt;count:SizeInt):shortstring;compilerproc;
begin
if count<0 then
count:=0;
if index>1 then
dec(index)
else
index:=0;
if index>length(s) then
count:=0
else
if count>length(s)-index then
count:=length(s)-index;
ShortstringClass(result).curlen:=count;
JLSystem.ArrayCopy(JLObject(ShortstringClass(s).fdata),index,JLObject(ShortstringClass(result).fdata),0,count);
end;
function fpc_char_copy(c:AnsiChar;index : SizeInt;count : SizeInt): shortstring;compilerproc;
begin
if (index=1) and (Count>0) then
fpc_char_Copy:=c
else
fpc_char_Copy:='';
end;
function upcase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=upcase(u);
end;
function lowercase(const s : shortstring) : shortstring;
var
u : unicodestring;
begin
u:=s;
result:=lowercase(u);
end;
Function Pos (Const Substr : Shortstring; Const Source : Shortstring) : SizeInt;
var
i,j,k,MaxLen, SubstrLen : SizeInt;
begin
Pos:=0;
SubstrLen:=Length(SubStr);
if SubstrLen>0 then
begin
MaxLen:=Length(source)-Length(SubStr);
i:=0;
while (i<=MaxLen) do
begin
inc(i);
j:=0;
k:=i-1;
while (j<SubstrLen) and
(ShortstringClass(SubStr).fdata[j]=ShortstringClass(Source).fdata[k]) do
begin
inc(j);
inc(k);
end;
if (j=SubstrLen) then
begin
Pos:=i;
exit;
end;
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 : AnsiChar; Const s : ShortString) : SizeInt;
var
i: SizeInt;
begin
for i:=1 to length(s) do
begin
if ShortstringClass(s).fdata[i-1]=c then
begin
pos:=i;
exit;
end;
end;
pos:=0;
end;

61
rtl/java/system.pp
View File

@ -24,7 +24,7 @@ Unit system;
{$define FPC_IS_SYSTEM}
{$I-,Q-,H-,R-,V-}
{$I-,Q-,H-,R-,V-,P+}
{$implicitexceptions off}
{$mode objfpc}
@ -122,6 +122,7 @@ type
{$i innr.inc}
{$i jmathh.inc}
{$i jrech.inc}
{$i sstringh.inc}
{$i jdynarrh.inc}
{$i astringh.inc}
@ -264,13 +265,6 @@ 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}
{$i jint64.inc}
function min(a,b : longint) : longint;
begin
@ -280,6 +274,14 @@ function min(a,b : longint) : longint;
min:=b;
end;
{$i sstrings.inc}
{$i astrings.inc}
{$i ustrings.inc}
{$i rtti.inc}
{$i jrec.inc}
{$i jint64.inc}
{ copying helpers }
procedure fpc_copy_shallow_array(src, dst: JLObject; srcstart: jint = -1; srccopylen: jint = -1);
@ -331,6 +333,27 @@ procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; s
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
dst[i]:=ShortstringClass(src[srcstart+i].clone);
end;
{ 1-dimensional setlength routines }
function fpc_setlength_dynarr_generic(aorg, anew: JLObject; deepcopy: boolean; docopy: boolean = true): JLObject;
@ -375,6 +398,19 @@ function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boole
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
@ -408,6 +444,13 @@ function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: bool
for i:=succ(partdone) to high(result) do
result[i]:=JLObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(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
@ -453,6 +496,8 @@ function fpc_dynarray_copy(src: JLObject; start, len: longint; ndim: longint; el
case eletype of
FPCJDynArrTypeRecord:
fpc_copy_jrecord_array(TJRecordArray(src),TJRecordArray(result),start,len);
FPCJDynArrTypeShortstring:
fpc_copy_jshortstring_array(TShortstringArray(src),TShortstringArray(result),start,len);
else
fpc_copy_shallow_array(src,result,start,len);
end

274
rtl/java/ustrings.inc
View File

@ -35,7 +35,7 @@ begin
result:=JLString.create(data);
end;
(*
procedure fpc_UnicodeStr_To_ShortStr (out res: ShortString;const S2 : UnicodeString); [Public, alias: 'FPC_UNICODESTR_TO_SHORTSTR'];compilerproc;
{
Converts a UnicodeString to a ShortString;
@ -48,9 +48,7 @@ begin
Size:=Length(S2);
if Size>0 then
begin
If Size>high(res) then
Size:=high(res);
widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(S2),temp,Size);
temp:=s2;
res:=temp;
end;
end;
@ -66,13 +64,8 @@ begin
result:='';
Size:=Length(S2);
if Size>0 then
begin
widestringmanager.Ansi2UnicodeMoveProc(PChar(@S2[1]),result,Size);
{ Terminating Zero }
PUnicodeChar(Pointer(fpc_ShortStr_To_UnicodeStr)+Size*sizeof(UnicodeChar))^:=#0;
end;
result:=unicodestring(JLString.Create(TJByteArray(ShortstringClass(S2).fdata),0,length(S2)));
end;
*)
Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc;
{
@ -235,31 +228,16 @@ begin
result:=chr(arrb[0]);
end;
(*
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_WChar_To_ShortStr(const c : WideChar): ShortString; compilerproc;
{
Converts a WideChar to a ShortString;
}
var
s: ansistring;
begin
widestringmanager.Wide2AnsiMoveProc(@c, s, 1);
fpc_WChar_To_ShortStr:= s;
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc;
{
Converts a WideChar to a ShortString;
}
var
s: ansistring;
u: unicodestring;
begin
widestringmanager.Wide2AnsiMoveProc(@c,s,1);
res:=s;
u:=c;
res:=u;
end;
{$endif FPC_STRTOSHORTSTRINGPROC}
*)
Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc;
{
@ -272,41 +250,19 @@ begin
result:=JLString.create(arr);
end;
(*
Function fpc_UChar_To_AnsiStr(const c : UnicodeChar): AnsiString; compilerproc;
{
Converts a UnicodeChar to a AnsiString;
}
begin
widestringmanager.Unicode2AnsiMoveProc(@c, fpc_UChar_To_AnsiStr, 1);
end;
{$ifndef FPC_STRTOSHORTSTRINGPROC}
Function fpc_UChar_To_ShortStr(const c : UnicodeChar): ShortString; compilerproc;
{
Converts a UnicodeChar to a ShortString;
}
var
s: ansistring;
u: unicodestring;
begin
widestringmanager.Unicode2AnsiMoveProc(@c, s, 1);
fpc_UChar_To_ShortStr:= s;
u:=c;
result:=u;
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_UChar_To_ShortStr(out res : shortstring;const c : UnicodeChar) compilerproc;
{
Converts a UnicodeChar to a ShortString;
}
var
s: ansistring;
begin
widestringmanager.Unicode2AnsiMoveProc(@c,s,1);
res:=s;
end;
{$endif FPC_STRTOSHORTSTRINGPROC}
(*
Function fpc_PChar_To_UnicodeStr(const p : pchar): UnicodeString; compilerproc;
Var
L : SizeInt;
@ -425,129 +381,45 @@ begin
result:=JLString.create(arr,0,i);
end;
Function real_widechararray_to_unicodestr(const arr: array of widechar; zerobased: boolean): Unicodestring;
var
i : SizeInt;
foundnull : boolean;
begin
if (zerobased) then
begin
foundnull:=false;
for i:=low(arr) to high(arr) do
if arr[i]=#0 then
begin
foundnull:=true;
break;
end;
if not foundnull then
i := high(arr)+1;
end
else
i := high(arr)+1;
result:=JLString.create(arr,0,i);
end;
Function fpc_WideCharArray_To_UnicodeStr(const arr: array of widechar; zerobased: boolean = true): UnicodeString; compilerproc;
var
i : SizeInt;
foundnull : boolean;
begin
if (zerobased) then
begin
foundnull:=false;
for i:=low(arr) to high(arr) do
if arr[i]=#0 then
begin
foundnull:=true;
break;
end;
if not foundnull then
i := high(arr)+1;
end
else
i := high(arr)+1;
result:=JLString.create(arr,0,i);
result:=real_widechararray_to_unicodestr(arr,zerobased);
end;
(*
{ due to their names, the following procedures should be in wstrings.inc,
however, the compiler generates code using this functions on all platforms }
{$ifndef FPC_STRTOSHORTSTRINGPROC}
function fpc_WideCharArray_To_ShortStr(const arr: array of widechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
var
l: longint;
index: longint;
len: byte;
temp: ansistring;
begin
l := high(arr)+1;
if l>=256 then
l:=255
else if l<0 then
l:=0;
if zerobased then
begin
index:=IndexWord(arr[0],l,0);
if (index < 0) then
len := l
else
len := index;
end
else
len := l;
widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
fpc_WideCharArray_To_ShortStr := temp;
end;
{$else FPC_STRTOSHORTSTRINGPROC}
procedure fpc_WideCharArray_To_ShortStr(out res : shortstring;const arr: array of widechar; zerobased: boolean = true);[public,alias:'FPC_WIDECHARARRAY_TO_SHORTSTR']; compilerproc;
var
l: longint;
index: ptrint;
len: byte;
temp: ansistring;
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
index:=IndexWord(arr[0],l,0);
if index<0 then
len:=l
else
len:=index;
end
else
len:=l;
widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),temp,len);
res:=temp;
res:=real_widechararray_to_unicodestr(arr,zerobased);
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);
if i = -1 then
i := high(arr)+1;
end
else
i := high(arr)+1;
SetLength(fpc_WideCharArray_To_AnsiStr,i);
widestringmanager.Wide2AnsiMoveProc (pwidechar(@arr),fpc_WideCharArray_To_AnsiStr,i);
{$endif}
result:=real_widechararray_to_unicodestr(arr,zerobased);
end;
Function fpc_WideCharArray_To_WideStr(const arr: array of widechar; zerobased: boolean = true): WideString; compilerproc;
var
i : SizeInt;
foundnull : boolean;
begin
if (zerobased) then
begin
foundnull:=false;
for i:=low(arr) to high(arr) do
if arr[i]=#0 then
begin
foundnull:=true;
break;
end;
if not foundnull then
i := high(arr)+1;
end
else
i := high(arr)+1;
result:=JLString.create(arr,0,i);
end;
procedure fpc_unicodestr_to_chararray(out res: array of AnsiChar; const src: UnicodeString); compilerproc;
var
i, len: SizeInt;
@ -591,7 +463,6 @@ begin
end;
(*
procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc;
var
len: SizeInt;
@ -600,84 +471,68 @@ begin
len := length(src);
{ make sure we don't dereference src if it can be nil (JM) }
if len > 0 then
widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
temp:=src;
len := length(temp);
if len > length(res) then
len := length(res);
{$r-}
move(temp[1],res[0],len*sizeof(unicodechar));
fillchar(res[len],(length(res)-len)*SizeOf(UnicodeChar),0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
JLString(temp).getChars(0,len,res,0);
JUArrays.fill(res,len,high(res),#0);
end;
(*
procedure fpc_shortstr_to_unicodechararray(out res: array of unicodechar; const src: ShortString); compilerproc;
var
len: longint;
temp : unicodestring;
begin
len := length(src);
{ make sure we don't access char 1 if length is 0 (JM) }
{ temp is initialized with an empty string, so no need to convert src in case
it's also empty}
if len > 0 then
widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len);
temp:=src;
len := length(temp);
if len > length(res) then
len := length(res);
{$r-}
move(temp[1],res[0],len*sizeof(unicodechar));
fillchar(res[len],(length(res)-len)*SizeOf(UnicodeChar),0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
if len > high(res)+1 then
len := high(res)+1;
JLString(temp).getChars(0,len,res,0);
JUArrays.fill(res,len,high(res),#0);
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
widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
temp:=src;
len := length(temp);
if len > length(res) then
len := length(res);
if len > high(res)+1 then
len := high(res)+1;
{$r-}
move(temp[1],res[0],len*sizeof(widechar));
fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
{$endif}
JLString(temp).getChars(0,len,res,0);
JUArrays.fill(res,len,high(res),#0);
end;
(*
procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc;
var
len: longint;
temp : widestring;
temp : unicodestring;
begin
len := length(src);
{ make sure we don't access char 1 if length is 0 (JM) }
{ temp is initialized with an empty string, so no need to convert src in case
it's also empty}
if len > 0 then
widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len);
temp:=src;
len := length(temp);
if len > length(res) then
len := length(res);
{$r-}
move(temp[1],res[0],len*sizeof(widechar));
fillchar(res[len],(length(res)-len)*SizeOf(WideChar),0);
{$ifdef RangeCheckWasOn}
{$r+}
{$endif}
if len > high(res)+1 then
len := high(res)+1;
JLString(temp).getChars(0,len,res,0);
JUArrays.fill(res,len,high(res),#0);
end;
*)
procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc;
var
@ -686,8 +541,7 @@ begin
len := length(src);
if len > length(res) then
len := length(res);
for i:=0 to len-1 do
res[i]:=src[i+1];
JLString(src).getChars(0,len,res,0);
end;