diff --git a/.gitattributes b/.gitattributes index 6342bea28c..9bf752ebe4 100644 --- a/.gitattributes +++ b/.gitattributes @@ -7359,6 +7359,8 @@ 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/system.pp svneol=native#text/plain +rtl/java/ustringh.inc svneol=native#text/plain +rtl/java/ustrings.inc svneol=native#text/plain rtl/jvm/makefile.cpu svneol=native#text/plain rtl/linux/Makefile svneol=native#text/plain rtl/linux/Makefile.fpc svneol=native#text/plain diff --git a/compiler/defcmp.pas b/compiler/defcmp.pas index 12d955ee12..4a3578f553 100644 --- a/compiler/defcmp.pas +++ b/compiler/defcmp.pas @@ -200,6 +200,12 @@ implementation exit; end; + { resolve anonymous external definitions } + if def_from.typ=objectdef then + def_from:=find_real_class_definition(tobjectdef(def_from),false); + if def_to.typ=objectdef then + def_to:=find_real_class_definition(tobjectdef(def_to),false); + { same def? then we've an exact match } if def_from=def_to then begin @@ -523,7 +529,13 @@ implementation begin doconv:=tc_intf_2_string; eq:=te_convert_l1; - end; + end + else if (def_from=java_jlstring) and + is_wide_or_unicode_string(def_to) then + begin + doconv:=tc_equal; + eq:=te_equal; + end end; end; end; @@ -1267,23 +1279,24 @@ implementation objectdef : begin - { Objective-C/Java classes (handle anonymous externals) } - if (def_from.typ=objectdef) and - (find_real_class_definition(tobjectdef(def_from),false) = - find_real_class_definition(tobjectdef(def_to),false)) then - begin - doconv:=tc_equal; - { exact, not equal, because can change between interface - and implementation } - eq:=te_exact; - end { object pascal objects } - else if (def_from.typ=objectdef) and + if (def_from.typ=objectdef) and (tobjectdef(def_from).is_related(tobjectdef(def_to))) then begin doconv:=tc_equal; eq:=te_convert_l1; end + { java.lang.string -> unicodestring } + else if (def_to=java_jlstring) and + (is_wide_or_unicode_string(def_from) or + (fromtreetype=stringconstn)) then + begin + doconv:=tc_equal; + if is_wide_or_unicode_string(def_from) then + eq:=te_equal + else + eq:=te_convert_l2; + end else { specific to implicit pointer object types } if is_implicit_pointer_object_type(def_to) then diff --git a/compiler/jvm/njvmadd.pas b/compiler/jvm/njvmadd.pas index 0ed47cb662..6976d90e7d 100644 --- a/compiler/jvm/njvmadd.pas +++ b/compiler/jvm/njvmadd.pas @@ -34,8 +34,9 @@ interface { tjvmaddnode } tjvmaddnode = class(tcgaddnode) - protected function pass_1: tnode;override; + protected + function first_addstring: tnode; override; function cmpnode2signedtopcmp: TOpCmp; @@ -54,12 +55,13 @@ interface uses systems, - cutils,verbose, + cutils,verbose,constexp, + symtable,symdef, paramgr,procinfo, aasmtai,aasmdata,aasmcpu,defutil, hlcgobj,hlcgcpu,cgutils, cpupara, - ncon,nset,nadd, + ncon,nset,nadd,ncal, cgobj; {***************************************************************************** @@ -74,6 +76,62 @@ interface end; + function tjvmaddnode.first_addstring: tnode; + var + cmpfuncname: string; + begin + { when we get here, we are sure that both the left and the right } + { node are both strings of the same stringtype (JM) } + case nodetype of + addn: + begin + if (left.nodetype=stringconstn) and (tstringconstnode(left).len=0) then + begin + result:=right; + left.free; + left:=nil; + right:=nil; + exit; + end; + if (right.nodetype=stringconstn) and (tstringconstnode(right).len=0) then + begin + result:=left; + left:=nil; + right.free; + right:=nil; + exit; + end; + + { create the call to the concat routine both strings as arguments } + result:=ccallnode.createintern('fpc_'+ + tstringdef(resultdef).stringtypname+'_concat', + ccallparanode.create(right, + ccallparanode.create(left,nil))); + { we reused the arguments } + left := nil; + right := nil; + end; + ltn,lten,gtn,gten,equaln,unequaln : + begin + { call compare routine } + cmpfuncname := 'fpc_'+tstringdef(left.resultdef).stringtypname+'_compare'; + { for equality checks use optimized version } + if nodetype in [equaln,unequaln] then + cmpfuncname := cmpfuncname + '_equal'; + + result := ccallnode.createintern(cmpfuncname, + ccallparanode.create(right,ccallparanode.create(left,nil))); + { and compare its result with 0 according to the original operator } + result := caddnode.create(nodetype,result, + cordconstnode.create(0,s32inttype,false)); + left := nil; + right := nil; + end; + else + internalerror(2011031401); + end; + end; + function tjvmaddnode.cmpnode2signedtopcmp: TOpCmp; begin case nodetype of diff --git a/compiler/jvm/njvmcnv.pas b/compiler/jvm/njvmcnv.pas index b2d8b03b42..35fe5dc3ae 100644 --- a/compiler/jvm/njvmcnv.pas +++ b/compiler/jvm/njvmcnv.pas @@ -31,6 +31,7 @@ interface type tjvmtypeconvnode = class(tcgtypeconvnode) function typecheck_dynarray_to_openarray: tnode; override; + function typecheck_string_to_chararray: tnode; override; procedure second_int_to_int;override; { procedure second_string_to_string;override; } @@ -99,6 +100,34 @@ implementation end; + function tjvmtypeconvnode.typecheck_string_to_chararray: tnode; + var + newblock: tblocknode; + newstat: tstatementnode; + restemp: ttempcreatenode; + chartype: string; + begin + if (left.nodetype = stringconstn) and + (tstringconstnode(left).cst_type=cst_conststring) then + inserttypeconv(left,cunicodestringtype); + { even constant strings have to be handled via a helper } + if is_widechar(tarraydef(resultdef).elementdef) then + chartype:='widechar' + else + chartype:='char'; + newblock:=internalstatements(newstat); + restemp:=ctempcreatenode.create(resultdef,resultdef.size,tt_persistent,false); + addstatement(newstat,restemp); + addstatement(newstat,ccallnode.createintern('fpc_'+tstringdef(left.resultdef).stringtypname+ + '_to_'+chartype+'array',ccallparanode.create(left,ccallparanode.create( + ctemprefnode.create(restemp),nil)))); + addstatement(newstat,ctempdeletenode.create_normal_temp(restemp)); + addstatement(newstat,ctemprefnode.create(restemp)); + result:=newblock; + left:=nil; + end; + + {***************************************************************************** FirstTypeConv *****************************************************************************} diff --git a/compiler/jvm/njvminl.pas b/compiler/jvm/njvminl.pas index 5c39e645a4..88f8cd8f27 100644 --- a/compiler/jvm/njvminl.pas +++ b/compiler/jvm/njvminl.pas @@ -37,6 +37,7 @@ interface function typecheck_new(var handled: boolean): tnode; function first_setlength_array: tnode; + function first_setlength_string: tnode; public { typecheck override to intercept handling } function pass_typecheck: tnode; override; @@ -55,6 +56,7 @@ interface *) function first_new: tnode; override; function first_setlength: tnode; override; + function first_length: tnode; override; procedure second_length; override; (* @@ -93,7 +95,8 @@ implementation begin typecheckpass(left); if is_dynamic_array(left.resultdef) or - is_open_array(left.resultdef) then + is_open_array(left.resultdef) or + is_wide_or_unicode_string(left.resultdef) then begin resultdef:=s32inttype; result:=nil; @@ -334,6 +337,44 @@ implementation end; + function tjvminlinenode.first_setlength_string: tnode; + var + newblock: tblocknode; + newstatement: tstatementnode; + lefttemp: ttempcreatenode; + assignmenttarget: tnode; + begin + if is_wide_or_unicode_string(left.resultdef) then + begin + { store left into a temp in case it may contain a function call + (which must not be evaluated twice) } + lefttemp:=maybereplacewithtempref(tcallparanode(left).left,tcallparanode(left).left.resultdef.size,false); + if assigned(lefttemp) then + begin + newblock:=internalstatements(newstatement); + addstatement(newstatement,lefttemp); + assignmenttarget:=ctemprefnode.create(lefttemp); + typecheckpass(tnode(assignmenttarget)); + end + else + assignmenttarget:=tcallparanode(left).left.getcopy; + { back to original order for the call } + left:=reverseparameters(tcallparanode(left)); + result:=cassignmentnode.create(assignmenttarget, + ccallnode.createintern('fpc_unicodestr_setlength',left)); + if assigned(lefttemp) then + begin + addstatement(newstatement,result); + addstatement(newstatement,ctempdeletenode.create(lefttemp)); + result:=newblock; + end; + left:=nil; + end + else + internalerror(2011031405); + end; + + function tjvminlinenode.first_setlength: tnode; begin @@ -351,12 +392,64 @@ implementation case left.resultdef.typ of arraydef: result:=first_setlength_array; + stringdef: + result:=first_setlength_string; else internalerror(2011031204); end; end; + function tjvminlinenode.first_length: tnode; + var + newblock: tblocknode; + newstatement: tstatementnode; + lentemp: ttempcreatenode; + ifcond, + stringnonnull, + stringnull: tnode; + psym: tsym; + begin + if is_wide_or_unicode_string(left.resultdef) then + begin + { if assigned(JLString(left)) then + lentemp:=JLString(left).length() + else + lentemp:=0; + --> return lentemp + } + newblock:=internalstatements(newstatement); + lentemp:=ctempcreatenode.create(s32inttype,s32inttype.size,tt_persistent,true); + addstatement(newstatement,lentemp); + { if-condition } + ifcond:=cinlinenode.create(in_assigned_x,false, + ccallparanode.create(ctypeconvnode.create_explicit(left.getcopy,java_jlstring),nil)); + { then-path (reuse left, since last use) } + psym:=search_struct_member(java_jlstring,'LENGTH'); + if not assigned(psym) or + (psym.typ<>procsym) then + internalerror(2011031403); + stringnonnull:=cassignmentnode.create( + ctemprefnode.create(lentemp), + ccallnode.create(nil,tprocsym(psym),psym.owner, + ctypeconvnode.create_explicit(left,java_jlstring),[])); + left:=nil; + { else-path} + stringnull:=cassignmentnode.create( + ctemprefnode.create(lentemp), + genintconstnode(0)); + { complete if-statement } + addstatement(newstatement,cifnode.create(ifcond,stringnonnull,stringnull)); + { return temp } + addstatement(newstatement,ctempdeletenode.create_normal_temp(lentemp)); + addstatement(newstatement,ctemprefnode.create(lentemp)); + result:=newblock; + end + else + result:=inherited first_length; + end; + + procedure tjvminlinenode.second_length; begin if is_dynamic_array(left.resultdef) or @@ -497,6 +590,7 @@ implementation var target: tnode; lenpara: tnode; + emptystr: ansichar; begin target:=tcallparanode(left).left; lenpara:=tcallparanode(tcallparanode(left).right).left; @@ -506,7 +600,13 @@ implementation internalerror(2011031801); secondpass(target); - if is_dynamic_array(target.resultdef) then + if is_wide_or_unicode_string(target.resultdef) then + begin + emptystr:=#0; + current_asmdata.CurrAsmList.concat(taicpu.op_string(a_ldc,0,@emptystr)); + thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1); + end + 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); diff --git a/compiler/jvm/njvmld.pas b/compiler/jvm/njvmld.pas index 8890396995..27044ac14d 100644 --- a/compiler/jvm/njvmld.pas +++ b/compiler/jvm/njvmld.pas @@ -36,6 +36,10 @@ type function is_addr_param_load: boolean; override; end; + tjvmassignmentnode = class(tcgassignmentnode) + function pass_1: tnode; override; + end; + tjvmarrayconstructornode = class(tcgarrayconstructornode) protected procedure makearrayref(var ref: treference; eledef: tdef); override; @@ -47,10 +51,42 @@ implementation uses verbose, aasmdata, - nld, - symsym,symdef,jvmdef, + nbas,nld,ncal,nmem,ncnv, + symsym,symdef,defutil,jvmdef, cgbase,hlcgobj; +{ tjvmassignmentnode } + +function tjvmassignmentnode.pass_1: tnode; + var + target: tnode; + begin + { intercept writes to string elements, because Java strings are immutable + -> detour via StringBuilder + } + target:=left.actualtargetnode; + if (target.nodetype=vecn) and + is_wide_or_unicode_string(tvecnode(target).left.resultdef) 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', + ccallparanode.create(right, + ccallparanode.create(tvecnode(target).right, + ccallparanode.create(tvecnode(target).left.getcopy,nil)))); + result:=cassignmentnode.create(tvecnode(target).left,result); + right:=nil; + tvecnode(target).left:=nil; + tvecnode(target).right:=nil; + exit; + end + else + result:=inherited; + end; + + function tjvmloadnode.is_addr_param_load: boolean; begin result:= @@ -82,6 +118,7 @@ procedure tjvmarrayconstructornode.advancearrayoffset(var ref: treference; elesi begin cloadnode:=tjvmloadnode; + cassignmentnode:=tjvmassignmentnode; carrayconstructornode:=tjvmarrayconstructornode; end. diff --git a/compiler/jvm/njvmmem.pas b/compiler/jvm/njvmmem.pas index 77ba013bd7..af3750b721 100644 --- a/compiler/jvm/njvmmem.pas +++ b/compiler/jvm/njvmmem.pas @@ -32,6 +32,7 @@ interface type tjvmvecnode = class(tcgvecnode) + function pass_1: tnode; override; procedure pass_generate_code;override; end; @@ -39,8 +40,9 @@ implementation uses systems, - cutils,verbose, - symdef,defutil, + cutils,verbose,constexp, + symconst,symtype,symtable,symsym,symdef,defutil, + nadd,ncal,ncnv,ncon, aasmdata,pass_2, cgutils,hlcgobj,hlcgcpu; @@ -48,6 +50,29 @@ implementation TJVMVECNODE *****************************************************************************} + function tjvmvecnode.pass_1: tnode; + var + psym: tsym; + begin + if is_wide_or_unicode_string(left.resultdef) then + begin + psym:=search_struct_member(java_jlstring,'CHARAT'); + if not assigned(psym) or + (psym.typ<>procsym) then + internalerror(2011031501); + { Pascal strings are 1-based, Java strings 0-based } + result:=ccallnode.create(ccallparanode.create( + caddnode.create(subn,right,genintconstnode(1)),nil),tprocsym(psym), + psym.owner,ctypeconvnode.create_explicit(left,java_jlstring),[]); + left:=nil; + right:=nil; + exit; + end + else + result:=inherited; + end; + + procedure tjvmvecnode.pass_generate_code; var newsize: tcgsize; diff --git a/compiler/jvmdef.pas b/compiler/jvmdef.pas index 0205dda712..115c6495a2 100644 --- a/compiler/jvmdef.pas +++ b/compiler/jvmdef.pas @@ -86,8 +86,9 @@ implementation stringdef : begin case tstringdef(def).stringtype of - { translated into Java.Lang.String } - st_widestring: + { translated into java.lang.String } + st_widestring, + st_unicodestring: encodedstr:=encodedstr+'Ljava/lang/String;'; else { May be handled via wrapping later } diff --git a/compiler/ninl.pas b/compiler/ninl.pas index 019ece5b9f..96908cf7bf 100644 --- a/compiler/ninl.pas +++ b/compiler/ninl.pas @@ -70,6 +70,7 @@ interface nodes are not generated by the parser. It's however used internally by the JVM backend to create new dynamic arrays. } function first_new: tnode; virtual; + function first_length: tnode; virtual; private function handle_str: tnode; function handle_reset_rewrite_typed: tnode; @@ -2898,13 +2899,7 @@ implementation in_length_x: begin - if is_shortstring(left.resultdef) then - expectloc:=left.expectloc - else - begin - { ansi/wide string } - expectloc:=LOC_REGISTER; - end; + result:=first_length; end; in_typeinfo_x: @@ -3428,6 +3423,18 @@ implementation result:=nil; end; + function tinlinenode.first_length: tnode; + begin + result:=nil; + if is_shortstring(left.resultdef) then + expectloc:=left.expectloc + else + begin + { ansi/wide string } + expectloc:=LOC_REGISTER; + end; + end; + function tinlinenode.first_pack_unpack: tnode; var loopstatement : tstatementnode; diff --git a/compiler/pdecobj.pas b/compiler/pdecobj.pas index ed0b677f50..b8105b45d5 100644 --- a/compiler/pdecobj.pas +++ b/compiler/pdecobj.pas @@ -1293,6 +1293,8 @@ implementation java_jlthrowable:=current_objectdef; if (current_objectdef.objname^='FPCBASERECORDTYPE') then java_fpcbaserecordtype:=current_objectdef; + if (current_objectdef.objname^='JLSTRING') then + java_jlstring:=current_objectdef; end; end; end; diff --git a/compiler/symdef.pas b/compiler/symdef.pas index 46ed1e24a1..6995986cda 100644 --- a/compiler/symdef.pas +++ b/compiler/symdef.pas @@ -783,6 +783,8 @@ interface java_jlthrowable : tobjectdef; { FPC base type for records } java_fpcbaserecordtype : tobjectdef; + { java.lang.String } + java_jlstring : tobjectdef; const {$ifdef i386} @@ -4703,6 +4705,8 @@ implementation java_jlthrowable:=self; if (objname^='FPCBASERECORDTYPE') then java_fpcbaserecordtype:=self; + if (objname^='JLSTRING') then + java_jlstring:=self; end; writing_class_record_dbginfo:=false; end; diff --git a/compiler/x86/nx86add.pas b/compiler/x86/nx86add.pas index 5f7ee2c751..a2f1b35f92 100644 --- a/compiler/x86/nx86add.pas +++ b/compiler/x86/nx86add.pas @@ -43,7 +43,7 @@ unit nx86add; procedure second_addfloatsse; public procedure second_addfloat;override; - procedure second_addsmallset;override; +// procedure second_addsmallset;override; procedure second_add64bit;override; procedure second_cmpfloat;override; procedure second_cmpsmallset;override; @@ -330,7 +330,7 @@ unit nx86add; {***************************************************************************** AddSmallSet *****************************************************************************} - +(* procedure tx86addnode.second_addsmallset; var setbase : aint; @@ -433,7 +433,7 @@ unit nx86add; if opsize<>int_cgsize(resultdef.size) then location_force_reg(current_asmdata.CurrAsmList,location,int_cgsize(resultdef.size),false); end; - +*) procedure tx86addnode.second_cmpsmallset; var diff --git a/rtl/java/compproc.inc b/rtl/java/compproc.inc index 91973de0c7..a491d09289 100644 --- a/rtl/java/compproc.inc +++ b/rtl/java/compproc.inc @@ -21,6 +21,579 @@ **********************************************************************} +{ some dummy types necessary to have generic resulttypes for certain compilerprocs } +type + { normally the array should be maxlongint big, but that will confuse + the debugger. The compiler will set the correct size of the array + internally. It's now set to 0..0 because when compiling with -gt, + the entire array will be trashed, so it must not be defined larger + than the minimal size (otherwise we can trash other memory) } + fpc_big_chararray = array[0..0] of AnsiChar; + fpc_big_widechararray = array[0..0] of widechar; + fpc_big_unicodechararray = array[0..0] of unicodechar; + fpc_small_set = bitpacked array[0..31] of 0..1; + fpc_normal_set = bitpacked array[0..255] of 0..1; + 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_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} +procedure fpc_pchar_to_shortstr(out res : shortstring;p:pchar); compilerproc; +{$endif FPC_STRTOSHORTSTRINGPROC} + +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; +procedure fpc_shortstr_uint(v : valuint;len : SizeInt;out s : shortstring); compilerproc; +{$ifndef FPUNONE} +procedure fpc_ShortStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : shortstring); compilerproc; +{$endif} +procedure fpc_shortstr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:shortstring);compilerproc; +procedure fpc_shortstr_bool(b : boolean;len:sizeint;out s:shortstring);compilerproc; +procedure fpc_ShortStr_Currency(c : currency; len,f : SizeInt; out s : shortstring); compilerproc; + +procedure fpc_chararray_sint(v : valsint;len : SizeInt;out a : array of AnsiChar); compilerproc; +procedure fpc_chararray_uint(v : valuint;len : SizeInt;out a : array of AnsiChar); compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +procedure fpc_AnsiStr_sint(v : valsint; Len : SizeInt; out S : AnsiString); compilerproc; +procedure fpc_AnsiStr_uint(v : valuint;Len : SizeInt; out S : AnsiString); compilerproc; +{$ifndef FPUNONE} +procedure fpc_AnsiStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : ansistring); compilerproc; +{$endif} +procedure fpc_ansistr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:ansistring); compilerproc; +procedure fpc_ansistr_bool(b : boolean;len:sizeint;out s:ansistring); compilerproc; +{$ifdef FPC_HAS_STR_CURRENCY} +procedure fpc_AnsiStr_Currency(c : currency;len,fr : SizeInt;out s : ansistring); compilerproc; +{$endif FPC_HAS_STR_CURRENCY} +{$endif FPC_HAS_FEATURE_ANSISTRINGS} + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + procedure fpc_WideStr_sint(v : valsint; Len : SizeInt; out S : WideString); compilerproc; + procedure fpc_WideStr_uint(v : valuint;Len : SizeInt; out S : WideString); compilerproc; + {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef VER2_2} + procedure fpc_UnicodeStr_sint(v : valsint; Len : SizeInt; out S : UnicodeString); compilerproc; + procedure fpc_UnicodeStr_uint(v : valuint;Len : SizeInt; out S : UnicodeString); compilerproc; + {$endif VER2_2} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$ifndef CPU64} + procedure fpc_shortstr_qword(v : qword;len : SizeInt;out s : shortstring); compilerproc; + procedure fpc_shortstr_int64(v : int64;len : SizeInt;out s : shortstring); compilerproc; + procedure fpc_chararray_qword(v : qword;len : SizeInt;out a : array of AnsiChar); compilerproc; + procedure fpc_chararray_int64(v : int64;len : SizeInt;out a : array of AnsiChar); compilerproc; + {$ifdef FPC_HAS_FEATURE_ANSISTRINGS} + procedure fpc_ansistr_qword(v : qword;len : SizeInt;out s : ansistring); compilerproc; + procedure fpc_ansistr_int64(v : int64;len : SizeInt;out s : ansistring); compilerproc; + {$endif FPC_HAS_FEATURE_ANSISTRINGS} + + {$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + procedure fpc_widestr_qword(v : qword;len : SizeInt;out s : widestring); compilerproc; + procedure fpc_widestr_int64(v : int64;len : SizeInt;out s : widestring); compilerproc; + {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef VER2_2} + procedure fpc_UnicodeStr_qword(v : qword;len : SizeInt;out s : UnicodeString); compilerproc; + procedure fpc_UnicodeStr_int64(v : int64;len : SizeInt;out s : UnicodeString); compilerproc; + {$endif VER2_2} + {$endif FPC_HAS_FEATURE_WIDESTRINGS} +{$endif CPU64} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef FPUNONE} + procedure fpc_WideStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : WideString); compilerproc; + {$endif} + procedure fpc_widestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:widestring);compilerproc; + procedure fpc_widestr_bool(b : boolean;len:sizeint;out s:widestring);compilerproc; + {$ifdef FPC_HAS_STR_CURRENCY} + procedure fpc_WideStr_Currency(c : Currency;len,fr : SizeInt;out s : WideString);compilerproc; + {$endif FPC_HAS_STR_CURRENCY} + {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef VER2_2} + {$ifndef FPUNONE} + procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString); compilerproc; + {$endif} + procedure fpc_unicodestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:unicodestring);compilerproc; + procedure fpc_unicodestr_bool(b : boolean;len:sizeint;out s:unicodestring);compilerproc; + {$ifdef FPC_HAS_STR_CURRENCY} + procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc; + {$endif FPC_HAS_STR_CURRENCY} + {$endif VER2_2} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$ifndef FPUNONE} +procedure fpc_chararray_Float(d : ValReal;len,fr,rt : SizeInt;out a : array of AnsiChar); compilerproc; +{$endif} +procedure fpc_chararray_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out a : array of AnsiChar);compilerproc; +procedure fpc_chararray_bool(b : boolean;len:sizeint;out a : array of AnsiChar);compilerproc; +{$ifdef FPC_HAS_STR_CURRENCY} +procedure fpc_chararray_Currency(c : Currency;len,fr : SizeInt;out a : array of AnsiChar);compilerproc; +{$endif FPC_HAS_STR_CURRENCY} + +{ Val() support } +{$ifndef FPUNONE} +Function fpc_Val_Real_ShortStr(const s : shortstring; out code : ValSInt): ValReal; compilerproc; +{$endif} +Function fpc_Val_SInt_ShortStr(DestSize: SizeInt; Const S: ShortString; out Code: ValSInt): ValSInt; compilerproc; +Function fpc_Val_UInt_Shortstr(Const S: ShortString; out Code: ValSInt): ValUInt; compilerproc; +function fpc_val_enum_shortstr(str2ordindex:pointer;const s:shortstring;out code:valsint):longint; compilerproc; +Function fpc_Val_Currency_ShortStr(const s : shortstring; out Code : ValSInt): currency; compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +{$ifndef FPUNONE} +Function fpc_Val_Real_AnsiStr(Const S : AnsiString; out Code : ValSInt): ValReal; compilerproc; +{$endif} +Function fpc_Val_UInt_AnsiStr (Const S : AnsiString; out Code : ValSInt): ValUInt; compilerproc; +Function fpc_Val_SInt_AnsiStr (DestSize: SizeInt; Const S : AnsiString; out Code : ValSInt): ValSInt; compilerproc; +Function fpc_Val_Currency_AnsiStr(Const S : AnsiString; out Code : ValSInt): Currency; compilerproc; +function fpc_Val_enum_ansistr(str2ordindex:pointer;const s:ansistring;out code:valsint):longint; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} + {$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef FPUNONE} + Function fpc_Val_Real_WideStr(Const S : WideString; out Code : ValSInt): ValReal; compilerproc; + {$endif} + Function fpc_Val_SInt_WideStr (DestSize: SizeInt; Const S : WideString; out Code : ValSInt): ValSInt; compilerproc; + Function fpc_Val_UInt_WideStr (Const S : WideString; out Code : ValSInt): ValUInt; compilerproc; + function fpc_val_Enum_WideStr (str2ordindex:pointer;const s:WideString;out code:valsint):longint;compilerproc; + Function fpc_Val_Currency_WideStr(Const S : WideString; out Code : ValSInt): Currency; compilerproc; + {$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} + {$ifndef VER2_2} + {$ifndef FPUNONE} + Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; compilerproc; + {$endif} + Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; compilerproc; + Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; compilerproc; + function fpc_val_Enum_UnicodeStr(str2ordindex:pointer;const s:UnicodeString;out code:valsint):longint;compilerproc; + Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; compilerproc; + {$endif VER2_2} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$ifndef CPU64} +Function fpc_val_int64_shortstr(Const S: ShortString; out Code: ValSInt): Int64; compilerproc; +Function fpc_val_qword_shortstr(Const S: ShortString; out Code: ValSInt): QWord; compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Function fpc_Val_qword_AnsiStr (Const S : AnsiString; out Code : ValSInt): qword;compilerproc; +Function fpc_Val_int64_AnsiStr (Const S : AnsiString; out Code : ValSInt): Int64; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +{$if not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} +Function fpc_Val_qword_WideStr (Const S : WideString; out Code : ValSInt): qword; compilerproc; +Function fpc_Val_int64_WideStr (Const S : WideString; out Code : ValSInt): Int64; compilerproc; +{$endif not(defined(FPC_WIDESTRING_EQUAL_UNICODESTRING)) or defined(VER2_2)} +{$ifndef VER2_2} +Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): qword; compilerproc; +Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; compilerproc; +{$endif VER2_2} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$endif CPU64} + +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Procedure fpc_ansistr_decr_ref (Var S : Pointer); compilerproc; +Procedure fpc_ansistr_incr_ref (S : Pointer); compilerproc; +Procedure fpc_AnsiStr_Assign (Var DestS : Pointer;S2 : Pointer); compilerproc; +{$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} +function fpc_AnsiStr_Concat (const S1,S2 : AnsiString): AnsiString; compilerproc; +function fpc_AnsiStr_Concat_multi (const sarr:array of Ansistring): ansistring; compilerproc; +{$endif STR_CONCAT_PROCS} +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; +{$ifdef EXTRAANSISHORT} +Procedure fpc_AnsiStr_ShortStr_Concat (Var S1: AnsiString; Var S2 : ShortString); compilerproc; +{$endif EXTRAANSISHORT} +{$ifndef FPC_STRTOSHORTSTRINGPROC} +function fpc_AnsiStr_To_ShortStr (high_of_res: SizeInt;const S2 : Ansistring): shortstring; compilerproc; +{$else FPC_STRTOSHORTSTRINGPROC} +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; +Function fpc_Char_To_AnsiStr(const c : AnsiChar): AnsiString; compilerproc; + +Function fpc_PChar_To_AnsiStr(const p : pchar): ansistring; compilerproc; +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_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_SetLength (Var S : AnsiString; l : SizeInt); compilerproc; +Function fpc_ansistr_Copy (Const S : AnsiString; Index,Size : SizeInt) : AnsiString;compilerproc; +{$ifdef EXTRAANSISHORT} +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; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +*) + +{***************************************************************************** + 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; +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; +function fpc_UnicodeStr_Concat_multi (const sarr:array of Unicodestring): unicodestring; compilerproc; +Function fpc_Char_To_UnicodeStr(const c : AnsiChar): UnicodeString; compilerproc; +Function fpc_CharArray_To_UnicodeStr(const arr: array of AnsiChar; zerobased: boolean = true): UnicodeString; compilerproc; + +procedure fpc_unicodestr_to_chararray(out res: array of AnsiChar; const src: UnicodeString); compilerproc; +//procedure fpc_shortstr_to_unicodechararray(out res: array of unicodechar; const src: ShortString); compilerproc; +//procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc; +procedure fpc_unicodestr_to_unicodechararray(out res: array of unicodechar; const src: UnicodeString); compilerproc; + +function fpc_unicodestr_setchar(const s: UnicodeString; const index: longint; const ch: unicodechar): UnicodeString; compilerproc; + +(* +{$ifndef FPC_STRTOSHORTSTRINGPROC} +Function fpc_UnicodeCharArray_To_ShortStr(const arr: array of unicodechar; zerobased: boolean = true): shortstring; compilerproc; +{$else FPC_STRTOSHORTSTRINGPROC} +procedure fpc_UnicodeCharArray_To_ShortStr(out res : shortstring;const arr: array of unicodechar; zerobased: boolean = true); compilerproc; +{$endif FPC_STRTOSHORTSTRINGPROC} +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} +Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; 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; +procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc; +*) +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; +(* +Procedure fpc_UnicodeStr_CheckZero(p : pointer); compilerproc; +Procedure fpc_UnicodeStr_CheckRange(len,index : SizeInt); compilerproc; +*) +Function fpc_UnicodeStr_SetLength (const S : UnicodeString; l : SizeInt): UnicodeString; compilerproc; +Function fpc_unicodestr_Copy (Const S : UnicodeString; Index,Size : SizeInt) : UnicodeString;compilerproc; +//function fpc_unicodestr_Unique(Var S : Pointer): Pointer; compilerproc; +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_WChar_To_ShortStr(out res : shortstring;const c : WideChar) compilerproc; +{$endif FPC_STRTOSHORTSTRINGPROC} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Function fpc_PUnicodeChar_To_AnsiStr(const p : punicodechar): ansistring; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +Function fpc_PUnicodeChar_To_UnicodeStr(const p : punicodechar): unicodestring; compilerproc; +Function fpc_PWideChar_To_UnicodeStr(const p : pwidechar): unicodestring; compilerproc; +{$ifndef FPC_STRTOSHORTSTRINGPROC} +Function fpc_PUnicodeChar_To_ShortStr(const p : punicodechar): shortstring; compilerproc; +{$else FPC_STRTOSHORTSTRINGPROC} +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} +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Function fpc_PWideChar_To_AnsiStr(const p : pwidechar): ansistring; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +{$ifndef FPC_STRTOSHORTSTRINGPROC} +Function fpc_PWideChar_To_ShortStr(const p : pwidechar): shortstring; compilerproc; +{$else FPC_STRTOSHORTSTRINGPROC} +procedure fpc_PWideChar_To_ShortStr(out res : shortstring;const p : pwidechar); compilerproc; +{$endif FPC_STRTOSHORTSTRINGPROC} +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +*) + +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +Function fpc_Char_To_WChar(const c : AnsiChar): WideChar; compilerproc; +Function fpc_WChar_To_Char(const c : WideChar): AnsiChar; compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +{$ifdef FPC_HAS_FEATURE_TEXTIO} +{ from text.inc } +Function fpc_get_input:PText;compilerproc; +Function fpc_get_output:PText;compilerproc; +Procedure fpc_Write_End(var f:Text); compilerproc; +Procedure fpc_Writeln_End(var f:Text); compilerproc; +Procedure fpc_Write_Text_ShortStr(Len : Longint;var f : Text;const s : String); compilerproc; +Procedure fpc_Write_Text_ShortStr_Iso(Len : Longint;var f : Text;const s : String); compilerproc; +Procedure fpc_Write_Text_Pchar_as_Array(Len : Longint;var f : Text;const s : array of AnsiChar; zerobased: boolean = true); compilerproc; +Procedure fpc_Write_Text_Pchar_as_Array_Iso(Len : Longint;var f : Text;const s : array of AnsiChar; zerobased: boolean = true); compilerproc; +Procedure fpc_Write_Text_PChar_As_Pointer(Len : Longint;var f : Text;p : PChar); compilerproc; +Procedure fpc_Write_Text_AnsiStr (Len : Longint; Var f : Text; const S : AnsiString); compilerproc; +{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} +Procedure fpc_Write_Text_WideStr (Len : Longint; Var f : Text; const S : WideString); compilerproc; +{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +Procedure fpc_Write_Text_UnicodeStr (Len : Longint; Var f : Text; const S : UnicodeString); compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +Procedure fpc_Write_Text_SInt(Len : Longint;var t : Text;l : ValSInt); compilerproc; +Procedure fpc_Write_Text_UInt(Len : Longint;var t : Text;l : ValUInt); compilerproc; +Procedure fpc_Write_Text_SInt_Iso(Len : Longint;var t : Text;l : ValSInt); compilerproc; +Procedure fpc_Write_Text_UInt_Iso(Len : Longint;var t : Text;l : ValUInt); compilerproc; +{$ifndef CPU64} +procedure fpc_write_text_qword(len : longint;var t : text;q : qword); compilerproc; +procedure fpc_write_text_int64(len : longint;var t : text;i : int64); compilerproc; +procedure fpc_write_text_qword_iso(len : longint;var t : text;q : qword); compilerproc; +procedure fpc_write_text_int64_iso(len : longint;var t : text;i : int64); compilerproc; +{$endif CPU64} +{$ifndef FPUNONE} +Procedure fpc_Write_Text_Float(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc; +Procedure fpc_Write_Text_Float_Iso(rt,fixkomma,Len : Longint;var t : Text;r : ValReal); compilerproc; +{$endif} +procedure fpc_write_text_enum(typinfo,ord2strindex:pointer;len:sizeint;var t:text;ordinal:longint); compilerproc; +{$ifdef FPC_HAS_STR_CURRENCY} +Procedure fpc_Write_Text_Currency(fixkomma,Len : Longint;var t : Text;c : Currency); compilerproc; +{$endif FPC_HAS_STR_CURRENCY} +Procedure fpc_Write_Text_Boolean(Len : Longint;var t : Text;b : Boolean); compilerproc; +Procedure fpc_Write_Text_Boolean_Iso(Len : Longint;var t : Text;b : Boolean); compilerproc; +Procedure fpc_Write_Text_Char(Len : Longint;var t : Text;c : AnsiChar); compilerproc; +Procedure fpc_Write_Text_Char_Iso(Len : Longint;var t : Text;c : AnsiChar); compilerproc; +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +Procedure fpc_Write_Text_WideChar(Len : Longint;var t : Text;c : WideChar); compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} + +function fpc_SetupWriteStr_Shortstr(out s: shortstring): PText; compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +function fpc_SetupWriteStr_Ansistr(out s: ansistring): PText; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +function fpc_SetupWriteStr_Unicodestr(out s: unicodestring): PText; compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} +function fpc_SetupWriteStr_Widestr(out s: widestring): PText; compilerproc; +{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} + +function fpc_SetupReadStr_Shortstr(const s: shortstring): PText; compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +function fpc_SetupReadStr_Ansistr(const s: ansistring): PText; compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +function fpc_SetupReadStr_Unicodestr(const s: unicodestring): PText; compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} +function fpc_SetupReadStr_Widestr(const s: widestring): PText; compilerproc; +{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} +{$endif FPC_HAS_FEATURE_TEXTIO} + +{$ifdef FPC_HAS_FEATURE_VARIANTS} +procedure fpc_variant_copy(d,s : pointer);compilerproc; +procedure fpc_variant_copy_overwrite(source, dest : pointer);compilerproc; +procedure fpc_write_text_variant(Len : Longint;var f : Text;const v : variant); compilerproc; +function fpc_variant_to_dynarray(const v : variant;typeinfo : pointer) : pointer;compilerproc; +function fpc_dynarray_to_variant(dynarr : pointer;typeinfo : pointer) : variant;compilerproc; +function fpc_variant_to_interface(const v : variant) : iinterface;compilerproc; +function fpc_interface_to_variant(const i : iinterface) : variant;compilerproc; +function fpc_variant_to_idispatch(const v : variant) : idispatch;compilerproc; +function fpc_idispatch_to_variant(const i : idispatch) : variant;compilerproc; +procedure fpc_vararray_get(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc; +procedure fpc_vararray_put(var d : variant;const s : variant;indices : plongint;len : sizeint);compilerproc; +procedure fpc_dispinvoke_variant(dest : pvardata;const source : tvardata; calldesc : pcalldesc;params : pointer);compilerproc; +{$endif FPC_HAS_FEATURE_VARIANTS} + +{$ifdef FPC_HAS_FEATURE_TEXTIO} +Procedure fpc_Read_End(var f:Text); compilerproc; +Procedure fpc_ReadLn_End(var f : Text); compilerproc; +Procedure fpc_ReadLn_End_Iso(var f : Text); compilerproc; +Procedure fpc_Read_Text_ShortStr(var f : Text;out s : String); compilerproc; +Procedure fpc_Read_Text_PChar_As_Pointer(var f : Text; const s : PChar); compilerproc; +Procedure fpc_Read_Text_PChar_As_Array(var f : Text;out s : array of AnsiChar; zerobased: boolean = false); compilerproc; +{$ifdef FPC_HAS_FEATURE_ANSISTRINGS} +Procedure fpc_Read_Text_AnsiStr(var f : Text;out s : AnsiString); compilerproc; +{$endif FPC_HAS_FEATURE_ANSISTRINGS} +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +Procedure fpc_Read_Text_UnicodeStr(var f : Text;out us : UnicodeString); compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +{$ifndef FPC_WIDESTRING_EQUAL_UNICODESTRING} +Procedure fpc_Read_Text_WideStr(var f : Text;out ws : WideString); compilerproc; +{$endif FPC_WIDESTRING_EQUAL_UNICODESTRING} +Procedure fpc_Read_Text_Char(var f : Text; out c : AnsiChar); compilerproc; +{$ifdef FPC_HAS_FEATURE_WIDESTRINGS} +procedure fpc_Read_Text_WideChar(var f : Text; out wc: widechar); compilerproc; +{$endif FPC_HAS_FEATURE_WIDESTRINGS} +Procedure fpc_Read_Text_Char_Iso(var f : Text; out c : AnsiChar); compilerproc; +Procedure fpc_Read_Text_SInt(var f : Text; out l :ValSInt); compilerproc; +Procedure fpc_Read_Text_UInt(var f : Text; out u :ValUInt); compilerproc; +{$ifndef FPUNONE} +Procedure fpc_Read_Text_Float(var f : Text; out v :ValReal); compilerproc; +{$endif} +procedure fpc_read_text_enum(str2ordindex:pointer;var t:text;out ordinal:longint); compilerproc; +procedure fpc_Read_Text_Currency(var f : Text; out v : Currency); compilerproc; +{$ifndef CPU64} +Procedure fpc_Read_Text_QWord(var f : text; out q : qword); compilerproc; +Procedure fpc_Read_Text_Int64(var f : text; out i : int64); compilerproc; +{$endif CPU64} +{$endif FPC_HAS_FEATURE_TEXTIO} + +{$ifdef FPC_INCLUDE_SOFTWARE_MOD_DIV} +function fpc_div_dword(n,z : dword) : dword; compilerproc; +function fpc_mod_dword(n,z : dword) : dword; compilerproc; +function fpc_div_longint(n,z : longint) : longint; compilerproc; +function fpc_mod_longint(n,z : longint) : longint; compilerproc; +{$endif FPC_INCLUDE_SOFTWARE_MOD_DIV} +(* +{ from int64.inc } +function fpc_div_qword(n,z : qword) : qword; compilerproc; +function fpc_mod_qword(n,z : qword) : qword; compilerproc; +function fpc_div_int64(n,z : int64) : int64; compilerproc; +function fpc_mod_int64(n,z : int64) : int64; compilerproc; +function fpc_mul_qword(f1,f2 : qword;checkoverflow : longbool) : qword; compilerproc; +function fpc_mul_int64(f1,f2 : int64;checkoverflow : longbool) : int64; compilerproc; +*) + +{$ifdef FPC_INCLUDE_SOFTWARE_SHIFT_INT64} +function fpc_shl_qword(value,shift : qword) : qword; compilerproc; +function fpc_shr_qword(value,shift : qword) : qword; compilerproc; +function fpc_shl_int64(value,shift : int64) : int64; compilerproc; +function fpc_shr_int64(value,shift : int64) : int64; compilerproc; +{$endif FPC_INCLUDE_SOFTWARE_SHIFT_INT64} +(* +{$ifndef FPUNONE} +function fpc_abs_real(d : ValReal) : ValReal;compilerproc; +function fpc_arctan_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_cos_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_exp_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_frac_real(d : ValReal) : ValReal;compilerproc; +function fpc_int_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_ln_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_pi_real : ValReal;compilerproc; +function fpc_sin_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_sqr_real(d : ValReal) : ValReal;compilerproc;{$ifdef MATHINLINE}inline;{$endif} +function fpc_sqrt_real(d : ValReal) : ValReal;compilerproc; +function fpc_round_real(d : ValReal) : int64;compilerproc; +function fpc_trunc_real(d : ValReal) : int64;compilerproc; +{$endif} +*) +{$ifdef FPC_HAS_FEATURE_CLASSES} +function fpc_do_is(aclass : tclass;aobject : tobject) : boolean; compilerproc; +function fpc_do_as(aclass : tclass;aobject : tobject): tobject; compilerproc; +procedure fpc_intf_decr_ref(var i: pointer); compilerproc; +procedure fpc_intf_incr_ref(i: pointer); compilerproc; +procedure fpc_intf_assign(var D: pointer; const S: pointer); compilerproc; +//procedure fpc_intf_assign_by_iid(var D: pointer; const S: pointer; const iid: TGUID); compilerproc; +function fpc_intf_is(const S: pointer; const iid: TGUID): Boolean; compilerproc; +function fpc_intf_is_class(const S: pointer; const aclass: tclass): Boolean; compilerproc; +function fpc_class_is_intf(const S: pointer; const iid: TGUID): Boolean; compilerproc; +function fpc_class_is_corbaintf(const S: pointer; const iid: Shortstring): Boolean; compilerproc; +function fpc_intf_cast(const S: pointer; const iid: TGUID): IInterface; compilerproc; +function fpc_intf_cast_class(const S: pointer; const aclass: tclass): pointer; compilerproc; +function fpc_class_cast_intf(const S: pointer; const iid: TGUID): IInterface; compilerproc; +function fpc_class_cast_corbaintf(const S: pointer; const iid: Shortstring): Pointer; compilerproc; +function fpc_intf_as(const S: pointer; const iid: TGUID): IInterface; compilerproc; +function fpc_intf_as_class(const S: pointer; const aclass: tclass): pointer; compilerproc; +function fpc_class_as_intf(const S: pointer; const iid: TGUID): IInterface; compilerproc; +function fpc_class_as_corbaintf(const S: pointer; const iid: Shortstring): Pointer; compilerproc; +{$ifdef FPC_HAS_FEATURE_VARIANTS} +procedure fpc_dispatch_by_id(Result: Pointer; const Dispatch: pointer;DispDesc: Pointer; Params: Pointer); compilerproc; +{$endif FPC_HAS_FEATURE_VARIANTS} +{$endif FPC_HAS_FEATURE_CLASSES} + + +{$ifdef FPC_HAS_FEATURE_EXCEPTIONS} +Function fpc_PushExceptAddr (Ft: Longint;_buf,_newaddr : pointer): PJmp_buf ; compilerproc; +Procedure fpc_PushExceptObj (Obj : TObject; AnAddr,AFrame : Pointer); compilerproc; +Function fpc_Raiseexception (Obj : TObject; AnAddr,AFrame : Pointer) : TObject; compilerproc; +Procedure fpc_PopAddrStack; compilerproc; +function fpc_PopObjectStack : TObject; compilerproc; +function fpc_PopSecondObjectStack : TObject; compilerproc; +Procedure fpc_ReRaise; compilerproc; +Function fpc_Catches(Objtype : TClass) : TObject; compilerproc; +Procedure fpc_DestroyException(o : TObject); compilerproc; +function fpc_GetExceptionAddr : Pointer; compilerproc; +{$endif FPC_HAS_FEATURE_EXCEPTIONS} + + +{$ifdef FPC_HAS_FEATURE_OBJECTS} +function fpc_help_constructor(_self:pointer;var _vmt:pointer;_vmt_pos:cardinal):pointer;compilerproc; +procedure fpc_help_destructor(_self,_vmt:pointer;vmt_pos:cardinal);compilerproc; +procedure fpc_help_fail(_self:pointer;var _vmt:pointer;vmt_pos:cardinal);compilerproc; +{$endif FPC_HAS_FEATURE_OBJECTS} + + +{$ifdef dummy} +procedure fpc_check_object(obj:pointer); compilerproc; +procedure fpc_check_object_ext(vmt,expvmt:pointer);compilerproc; +{$endif dummy} + + {$ifdef FPC_HAS_FEATURE_RTTI} Procedure fpc_Initialize (Data,TypeInfo : pointer); compilerproc; Procedure fpc_finalize (Data,TypeInfo: Pointer); compilerproc; @@ -33,6 +606,17 @@ procedure fpc_decref_array(data,typeinfo: pointer; count: sizeint); compilerproc Function fpc_Copy (Src, Dest, TypeInfo : Pointer) : SizeInt; compilerproc; Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline; {$endif FPC_HAS_FEATURE_RTTI} +{ array initialisation helpers (for open array "out" parameters whose elements + are normally refcounted) } +{ open array of unicodestring. normalarrdim contains the number of dimensions + a regular array, if any, that contains these unicodestrings. E.g.: + type + tarr = array[1..10,2..9] of unicodestring; + + procedure test(out arr: array of tarr); + -> normalarrdim will be 2 +} +procedure fpc_initialize_array_unicodestring(arr: TJObjectArray; normalarrdim: longint);compilerproc; { normalarrdim contains the number of dimensions a regular array, if any, that contains these unicodestrings. E.g.: type @@ -54,3 +638,68 @@ Procedure fpc_Copy_proc (Src, Dest, TypeInfo : Pointer); compilerproc; inline; procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc; procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType);compilerproc; +(* +{$ifdef FPC_SETBASE_USED} +procedure fpc_varset_load(const l;sourcesize : longint;var dest;size,srcminusdstbase : ptrint); compilerproc; +{$else} +procedure fpc_varset_load(const l;sourcesize : longint;var dest;size : ptrint); compilerproc; +{$endif} +procedure fpc_varset_create_element(b,size : ptrint; var data); compilerproc; +procedure fpc_varset_set(const source;var dest; b,size : ptrint); compilerproc; +procedure fpc_varset_unset(const source;var dest; b,size : ptrint); compilerproc; +procedure fpc_varset_set_range(const orgset; var dest;l,h,size : ptrint); compilerproc; +procedure fpc_varset_add_sets(const set1,set2; var dest;size : ptrint); compilerproc; +procedure fpc_varset_mul_sets(const set1,set2; var dest;size : ptrint); compilerproc; +procedure fpc_varset_sub_sets(const set1,set2; var dest;size : ptrint); compilerproc; +procedure fpc_varset_symdif_sets(const set1,set2; var dest;size : ptrint); compilerproc; +function fpc_varset_comp_sets(const set1,set2;size : ptrint):boolean; compilerproc; +function fpc_varset_contains_sets(const set1,set2;size : ptrint):boolean; compilerproc; + +{$ifdef LARGESETS} +procedure fpc_largeset_set_word(p : pointer;b : word); compilerproc; +procedure fpc_largeset_in_word(p : pointer;b : word); compilerproc; +procedure fpc_largeset_add_sets(set1,set2,dest : pointer;size : longint); compilerproc; +procedure fpc_largeset_sets(set1,set2,dest : pointer;size : longint); compilerproc; +procedure fpc_largeset_sub_sets(set1,set2,dest : pointer;size : longint); compilerproc; +procedure fpc_largeset_symdif_sets(set1,set2,dest : pointer;size : longint); compilerproc; +procedure fpc_largeset_comp_sets(set1,set2 : pointer;size : longint); compilerproc; +procedure fpc_largeset_contains_sets(set1,set2 : pointer; size: longint); compilerproc; +{$endif LARGESETS} + +procedure fpc_rangeerror; compilerproc; +procedure fpc_divbyzero; compilerproc; +procedure fpc_overflow; compilerproc; +procedure fpc_iocheck; compilerproc; + +procedure fpc_InitializeUnits; compilerproc; +// not generated by compiler, called directly in system unit +// procedure fpc_FinalizeUnits; compilerproc; + +{ +Procedure fpc_do_exit; compilerproc; +Procedure fpc_lib_exit; compilerproc; +Procedure fpc_HandleErrorAddrFrame (Errno : longint;addr,frame : pointer); compilerproc; +Procedure fpc_HandleError (Errno : longint); compilerproc; +} + +procedure fpc_AbstractErrorIntern;compilerproc; +procedure fpc_assert(Const Msg,FName:Shortstring;LineNo:Longint;ErrorAddr:Pointer); compilerproc; +*) + +{$ifdef FPC_HAS_FEATURE_FILEIO} +Procedure fpc_reset_typed(var f : TypedFile;Size : Longint); compilerproc; +Procedure fpc_rewrite_typed(var f : TypedFile;Size : Longint); compilerproc; +Procedure fpc_reset_typed_iso(var f : TypedFile;Size : Longint); compilerproc; +Procedure fpc_rewrite_typed_iso(var f : TypedFile;Size : Longint); compilerproc; +Procedure fpc_typed_write(TypeSize : Longint;var f : TypedFile;const Buf); compilerproc; +Procedure fpc_typed_read(TypeSize : Longint;var f : TypedFile;out Buf); compilerproc; +{$endif FPC_HAS_FEATURE_FILEIO} + +{$ifdef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} +function fpc_int64_to_double(i: int64): double; compilerproc; +function fpc_qword_to_double(q: qword): double; compilerproc; +{$endif FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} +(* +function fpc_setjmp(var s : jmp_buf) : longint; compilerproc; +procedure fpc_longjmp(var s : jmp_buf; value : longint); compilerproc; +*) diff --git a/rtl/java/jdynarrh.inc b/rtl/java/jdynarrh.inc index 119db807ef..62a4b9804a 100644 --- a/rtl/java/jdynarrh.inc +++ b/rtl/java/jdynarrh.inc @@ -25,6 +25,7 @@ type TJDoubleArray = array of jdouble; TJObjectArray = array of JLObject; TJRecordArray = array of FpcBaseRecordType; + TJStringArray = array of unicodestring; const FPCJDynArrTypeJByte = 'B'; diff --git a/rtl/java/rtti.inc b/rtl/java/rtti.inc index 42ae5d5741..8e95ff9e96 100644 --- a/rtl/java/rtti.inc +++ b/rtl/java/rtti.inc @@ -12,6 +12,25 @@ **********************************************************************} +procedure fpc_initialize_array_jstring_intern(arr: TJObjectArray; normalarrdim: longint); external name 'fpc_initialize_array_unicodestring'; + +procedure fpc_initialize_array_unicodestring(arr: TJObjectArray; normalarrdim: longint);compilerproc; + var + i: longint; + begin + if normalarrdim > 0 then + begin + for i:=low(arr) to high(arr) do + fpc_initialize_array_jstring_intern(TJObjectArray(arr[i]),normalarrdim-1); + end + else + begin + for i:=low(arr) to high(arr) do + unicodestring(arr[i]):=''; + end; + end; + + procedure fpc_initialize_array_dynarr_intern(arr: TJObjectArray; normalarrdim: longint); external name 'fpc_initialize_array_dynarr'; procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc; diff --git a/rtl/java/system.pp b/rtl/java/system.pp index 394d425f43..acb2099e84 100644 --- a/rtl/java/system.pp +++ b/rtl/java/system.pp @@ -28,7 +28,15 @@ Unit system; {$implicitexceptions off} {$mode objfpc} +{$undef FPC_HAS_FEATURE_ANSISTRINGS} +{$undef FPC_HAS_FEATURE_TEXTIO} +{$undef FPC_HAS_FEATURE_VARIANTS} +{$undef FPC_HAS_FEATURE_CLASSES} +{$undef FPC_HAS_FEATURE_EXCEPTIONS} +{$undef FPC_HAS_FEATURE_OBJECTS} {$undef FPC_HAS_FEATURE_RTTI} +{$undef FPC_HAS_FEATURE_FILEIO} +{$undef FPC_INCLUDE_SOFTWARE_INT64_TO_DOUBLE} Type { The compiler has all integer types defined internally. Here @@ -37,9 +45,16 @@ Type Cardinal = LongWord; Integer = SmallInt; UInt64 = QWord; - + SizeInt = Longint; + SizeUInt = Longint; + PtrInt = Longint; + PtrUInt = Longint; + ValReal = Double; - + + AnsiChar = Char; + UnicodeChar = WideChar; + { map comp to int64, } Comp = Int64; @@ -109,8 +124,62 @@ type {$i jrech.inc} {$i jdynarrh.inc} +Function lo(i : Integer) : byte; [INTERNPROC: fpc_in_lo_Word]; +Function lo(w : Word) : byte; [INTERNPROC: fpc_in_lo_Word]; +Function lo(l : Longint) : Word; [INTERNPROC: fpc_in_lo_long]; +Function lo(l : DWord) : Word; [INTERNPROC: fpc_in_lo_long]; +Function lo(i : Int64) : DWord; [INTERNPROC: fpc_in_lo_qword]; +Function lo(q : QWord) : DWord; [INTERNPROC: fpc_in_lo_qword]; +Function hi(i : Integer) : byte; [INTERNPROC: fpc_in_hi_Word]; +Function hi(w : Word) : byte; [INTERNPROC: fpc_in_hi_Word]; +Function hi(l : Longint) : Word; [INTERNPROC: fpc_in_hi_long]; +Function hi(l : DWord) : Word; [INTERNPROC: fpc_in_hi_long]; +Function hi(i : Int64) : DWord; [INTERNPROC: fpc_in_hi_qword]; +Function hi(q : QWord) : DWord; [INTERNPROC: fpc_in_hi_qword]; + +Function chr(b : byte) : AnsiChar; [INTERNPROC: fpc_in_chr_byte]; + +function RorByte(Const AValue : Byte): Byte;[internproc:fpc_in_ror_x]; +function RorByte(Const AValue : Byte;Dist : Byte): Byte;[internproc:fpc_in_ror_x_x]; + +function RolByte(Const AValue : Byte): Byte;[internproc:fpc_in_rol_x]; +function RolByte(Const AValue : Byte;Dist : Byte): Byte;[internproc:fpc_in_rol_x_x]; + +function RorWord(Const AValue : Word): Word;[internproc:fpc_in_ror_x]; +function RorWord(Const AValue : Word;Dist : Byte): Word;[internproc:fpc_in_ror_x_x]; + +function RolWord(Const AValue : Word): Word;[internproc:fpc_in_rol_x]; +function RolWord(Const AValue : Word;Dist : Byte): Word;[internproc:fpc_in_rol_x_x]; + +function RorDWord(Const AValue : DWord): DWord;[internproc:fpc_in_ror_x]; +function RorDWord(Const AValue : DWord;Dist : Byte): DWord;[internproc:fpc_in_ror_x_x]; + +function RolDWord(Const AValue : DWord): DWord;[internproc:fpc_in_rol_x]; +function RolDWord(Const AValue : DWord;Dist : Byte): DWord;[internproc:fpc_in_rol_x_x]; + +function RorQWord(Const AValue : QWord): QWord;[internproc:fpc_in_ror_x]; +function RorQWord(Const AValue : QWord;Dist : Byte): QWord;[internproc:fpc_in_ror_x_x]; + +function RolQWord(Const AValue : QWord): QWord;[internproc:fpc_in_rol_x]; +function RolQWord(Const AValue : QWord;Dist : Byte): QWord;[internproc:fpc_in_rol_x_x]; + +function SarShortint(Const AValue : Shortint): Shortint;[internproc:fpc_in_sar_x]; +function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;[internproc:fpc_in_sar_x_y]; + +function SarSmallint(Const AValue : Smallint): Smallint;[internproc:fpc_in_sar_x]; +function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;[internproc:fpc_in_sar_x_y]; + +function SarLongint(Const AValue : Longint): Longint;[internproc:fpc_in_sar_x]; +function SarLongint(Const AValue : Longint;Shift : Byte): Longint;[internproc:fpc_in_sar_x_y]; + +function SarInt64(Const AValue : Int64): Int64;[internproc:fpc_in_sar_x]; +function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_sar_x_y]; + + {$i compproc.inc} +{$i ustringh.inc} + {*****************************************************************************} implementation {*****************************************************************************} @@ -133,6 +202,7 @@ type ********************************************************************** } +{$i ustrings.inc} {$i rtti.inc} {$i jrec.inc} @@ -482,3 +552,4 @@ function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: bool *****************************************************************************} end. + diff --git a/rtl/java/ustringh.inc b/rtl/java/ustringh.inc new file mode 100644 index 0000000000..926d0293e0 --- /dev/null +++ b/rtl/java/ustringh.inc @@ -0,0 +1,81 @@ +{ + 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 UnicodeStrings with 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. + + **********************************************************************} + + +Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt; +Function Pos (c : Char; Const s : UnicodeString) : SizeInt; +Function Pos (c : UnicodeChar; Const s : UnicodeString) : 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 UpCase(const s : UnicodeString) : UnicodeString; +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); + +Type + { hooks for internationalization + please add new procedures at the end, it makes it easier to detect new procedures } + TUnicodeStringManager = class + collator: JTCollator; + constructor create; + end; + +var + widestringmanager : TUnicodeStringManager; + +//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); + + diff --git a/rtl/java/ustrings.inc b/rtl/java/ustrings.inc new file mode 100644 index 0000000000..1d31b81a7f --- /dev/null +++ b/rtl/java/ustrings.inc @@ -0,0 +1,1843 @@ +{ + This file is part of the Free Pascal run time library. + Copyright (c) 1999-2005 by Florian Klaempfl, + Copyright (c) 2011 by Jonas Maebe, + members of the Free Pascal development team. + + This file implements support routines for UTF-8 strings with 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. + + **********************************************************************} + +{$i wustrings.inc} + +{ + This file contains the implementation of the UnicodeString type, + which on the Java platforms is an alias for java.lang.String +} + + +Function NewUnicodeString(Len : SizeInt) : JLString; +{ + Allocate a new UnicodeString on the heap. + initialize it to zero length and reference count 1. +} +var + data: array of jchar; +begin + setlength(data,len); + 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; +} +Var + Size : SizeInt; + temp : ansistring; +begin + res:=''; + Size:=Length(S2); + if Size>0 then + begin + If Size>high(res) then + Size:=high(res); + widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(S2),temp,Size); + res:=temp; + end; +end; + + +Function fpc_ShortStr_To_UnicodeStr (Const S2 : ShortString): UnicodeString;compilerproc; +{ + Converts a ShortString to a UnicodeString; +} +Var + Size : SizeInt; +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; +end; + + +Function fpc_UnicodeStr_To_AnsiStr (const S2 : UnicodeString): AnsiString; compilerproc; +{ + Converts a UnicodeString to an AnsiString +} +Var + Size : SizeInt; +begin + result:=''; + Size:=Length(S2); + if Size>0 then + widestringmanager.Unicode2AnsiMoveProc(PUnicodeChar(Pointer(S2)),result,Size); +end; + + +Function fpc_AnsiStr_To_UnicodeStr (Const S2 : AnsiString): UnicodeString; compilerproc; +{ + Converts an AnsiString to a UnicodeString; +} +Var + Size : SizeInt; +begin + result:=''; + Size:=Length(S2); + if Size>0 then + widestringmanager.Ansi2UnicodeMoveProc(PChar(S2),result,Size); +end; +*) + +Function fpc_UnicodeStr_To_WideStr (const S2 : UnicodeString): WideString; compilerproc; + begin + result:=s2; + end; + + +Function fpc_WideStr_To_UnicodeStr (Const S2 : WideString): UnicodeString; compilerproc; + begin + result:=s2; + end; + +function fpc_UnicodeStr_Concat (const S1,S2 : UnicodeString): UnicodeString; compilerproc; +Var + sb: JLStringBuilder; +begin + { only assign if s1 or s2 is empty } + if (length(S1)=0) then + begin + result:=s2; + exit; + end; + if (length(S2)=0) then + begin + result:=s1; + exit; + end; + sb:=JLStringBuilder.create(S1); + sb.append(s2); + result:=sb.toString; +end; + + +function fpc_UnicodeStr_Concat_multi (const sarr:array of Unicodestring): unicodestring; compilerproc; +Var + i : Longint; + Size,NewSize : SizeInt; + sb: JLStringBuilder; +begin + { First calculate size of the result so we can allocate a StringBuilder of + the right size } + NewSize:=0; + for i:=low(sarr) to high(sarr) do + inc(Newsize,length(sarr[i])); + sb:=JLStringBuilder.create(NewSize); + for i:=low(sarr) to high(sarr) do + begin + if length(sarr[i])>0 then + sb.append(sarr[i]); + end; + result:=sb.toString; +end; + + +Function fpc_Char_To_UChar(const c : AnsiChar): UnicodeChar; compilerproc; +var + str: JLString; + arr: array of jbyte; +begin + setlength(arr,1); + arr[0]:=ord(c); + result:=JLString.create(arr,0,1).charAt(0); +end; + + + +Function fpc_Char_To_UnicodeStr(const c : AnsiChar): UnicodeString; compilerproc; +{ + Converts a AnsiChar to a UnicodeString; +} +var + str: JLString; + arr: array of jbyte; +begin + setlength(arr,1); + arr[0]:=ord(c); + result:=JLString.create(arr,0,1); +end; + + +Function fpc_UChar_To_Char(const c : UnicodeChar): AnsiChar; compilerproc; +{ + Converts a UnicodeChar to a AnsiChar; +} +var + arrb: array of jbyte; + arrw: array of jchar; + str: JLString; +begin + setlength(arrw,1); + arrw[0]:=c; + str:=JLString.create(arrw); + arrb:=str.getbytes(); + result:=chr(arrb[0]); +end; + + +Function fpc_WChar_To_UnicodeStr(const c : WideChar): UnicodeString; compilerproc; +{ + Converts a WideChar to a UnicodeString; +} +var + arrw: array of jchar; +begin + setlength(arrw,1); + arrw[0]:=c; + result:=JLString.create(arrw); +end; + + +Function fpc_Char_To_WChar(const c : AnsiChar): WideChar; compilerproc; +{ + Converts a AnsiChar to a WideChar; +} +var + str: JLString; + arr: array of jbyte; +begin + setlength(arr,1); + arr[0]:=ord(c); + result:=JLString.create(arr,0,1).charAt(0); +end; + + +Function fpc_WChar_To_Char(const c : WideChar): AnsiChar; compilerproc; +{ + Converts a WideChar to a AnsiChar; +} +var + arrb: array of jbyte; + arrw: array of jchar; +begin + setlength(arrw,1); + arrw[0]:=c; + arrb:=JLString.create(arrw).getbytes(); + 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; +begin + widestringmanager.Wide2AnsiMoveProc(@c,s,1); + res:=s; +end; +{$endif FPC_STRTOSHORTSTRINGPROC} +*) + +Function fpc_UChar_To_UnicodeStr(const c : UnicodeChar): UnicodeString; compilerproc; +{ + Converts a UnicodeChar to a UnicodeString; +} +var + arr: array of UnicodeChar; +begin + setlength(arr,1); + arr[0]:=c; + 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; +begin + widestringmanager.Unicode2AnsiMoveProc(@c, s, 1); + fpc_UChar_To_ShortStr:= s; +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; +begin + if (not assigned(p)) or (p[0]=#0) Then + begin + fpc_pchar_to_unicodestr := ''; + exit; + end; + l:=IndexChar(p^,-1,#0); + widestringmanager.Ansi2UnicodeMoveProc(P,fpc_PChar_To_UnicodeStr,l); +end; +*) + +Function fpc_CharArray_To_UnicodeStr(const arr: array of ansichar; zerobased: boolean = true): UnicodeString; compilerproc; +var + i,j : SizeInt; + localarr: array of jbyte; + foundnull: boolean; +begin + if (zerobased) then + begin + if (arr[0]=#0) Then + begin + fpc_chararray_to_unicodestr := ''; + exit; + end; + 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; + setlength(localarr,i); + for j:=0 to i-1 do + localarr[j]:=ord(arr[j]); + result:=JLString.create(localarr,0,i); +end; + +(* +function fpc_UnicodeCharArray_To_ShortStr(const arr: array of unicodechar; zerobased: boolean = true): shortstring;[public,alias:'FPC_UNICODECHARARRAY_TO_SHORTSTR']; compilerproc; +var + l: longint; + index: longint; + len: byte; + temp: ansistring; + foundnull: boolean; +begin + l := high(arr)+1; + if l>=256 then + l:=255 + 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; + result:=JLString.create(arr,0,l); +end; + + +Function fpc_UnicodeCharArray_To_AnsiStr(const arr: array of unicodechar; zerobased: boolean = true): AnsiString; compilerproc; +var + i : SizeInt; +begin + 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_UnicodeCharArray_To_AnsiStr,i); + widestringmanager.Unicode2AnsiMoveProc (punicodechar(@arr),fpc_UnicodeCharArray_To_AnsiStr,i); +end; +*) + +Function fpc_UnicodeCharArray_To_UnicodeStr(const arr: array of unicodechar; 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); +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); +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; +end; +{$endif FPC_STRTOSHORTSTRINGPROC} + +Function fpc_WideCharArray_To_AnsiStr(const arr: array of widechar; zerobased: boolean = true): AnsiString; compilerproc; +var + i : SizeInt; +begin + 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); +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; + temp: array of jbyte; +begin + len := length(src); + { make sure we don't dereference src if it can be nil (JM) } + if len > 0 then + begin + temp:=JLString(src).getBytes; + if len > length(temp) then + len := length(temp); + for i := 0 to len-1 do + res[i] := chr(temp[i]); + end; +end; + + +procedure fpc_unicodestr_to_unicodechararray(out res: array of unicodechar; const src: UnicodeString); compilerproc; +var + len: SizeInt; +begin + len := length(src); + { make sure we don't dereference src if it can be nil (JM) } + if len > 0 then + begin + if len > high(res)+1 then + len := high(res)+1; + JLString(src).getChars(0,len,res,0); + end; +end; + +function fpc_unicodestr_setchar(const s: UnicodeString; const index: longint; const ch: unicodechar): UnicodeString; compilerproc; +var + sb: JLStringBuilder; +begin + sb:=JLStringBuilder.create(s); + { string indexes are 1-based in Pascal, 0-based in Java } + sb.setCharAt(index-1,ch); + result:=sb.toString(); +end; + + +(* +procedure fpc_ansistr_to_unicodechararray(out res: array of unicodechar; const src: AnsiString); compilerproc; +var + len: SizeInt; + temp: unicodestring; +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); + 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} +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) } + if len > 0 then + widestringmanager.ansi2unicodemoveproc(pchar(@src[1]),temp,len); + 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} +end; + +procedure fpc_ansistr_to_widechararray(out res: array of widechar; const src: AnsiString); compilerproc; +var + len: SizeInt; + temp: widestring; +begin + 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); + 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} +end; + +procedure fpc_shortstr_to_widechararray(out res: array of widechar; const src: ShortString); compilerproc; +var + len: longint; + temp : widestring; +begin + len := length(src); + { make sure we don't access char 1 if length is 0 (JM) } + if len > 0 then + widestringmanager.ansi2widemoveproc(pchar(@src[1]),temp,len); + 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} +end; +*) + +procedure fpc_unicodestr_to_widechararray(out res: array of widechar; const src: UnicodeString); compilerproc; +var + i, len: SizeInt; +begin + len := length(src); + if len > length(res) then + len := length(res); + for i:=0 to len-1 do + res[i]:=src[i+1]; +end; + + +Function fpc_UnicodeStr_Compare(const S1,S2 : UnicodeString): SizeInt; compilerproc; +{ + Compares 2 UnicodeStrings; + The result is + <0 if S10 if S1>S2 +} +Var + MaxI,Temp : SizeInt; +begin + if JLObject(S1)=JLObject(S2) then + begin + result:=0; + exit; + end; + result:=JLString(S1).compareTo(S2); +end; + +Function fpc_UnicodeStr_Compare_Equal(const S1,S2 : UnicodeString): SizeInt; compilerproc; +{ + Compares 2 UnicodeStrings for equality only; + The result is + 0 if S1=S2 + <>0 if S1<>S2 +} +Var + MaxI : SizeInt; +begin + result:=ord(JLString(S1).equals(JLString(S2))); +end; + +function fpc_UnicodeStr_SetLength(const S : UnicodeString; l : SizeInt): UnicodeString; compilerproc; +{ + Sets The length of string S to L. + Makes sure S is unique, and contains enough room. + Returns new val +} +Var + movelen: SizeInt; + chars: array of widechar; + strlen: SizeInt; +begin + if (l>0) then + begin + if JLObject(S)=nil then + begin + { Need a completely new string...} + result:=NewUnicodeString(l); + end + { no need to create a new string, since Java strings are immutable } + else + begin + strlen:=length(s); + if l=strlen then + result:=s + else if (lLength(S)) or + (Index+Size>Length(S)) then + Size:=Length(S)-Index; + If Size>0 then + result:=JLString(s).subString(Index,Size) + else + result:=''; +end; + + +Function Pos (Const Substr : UnicodeString; Const Source : UnicodeString) : SizeInt; +begin + Pos:=0; + if Length(SubStr)>0 then + Pos:=JLString(Source).indexOf(SubStr)+1; +end; + + +{ Faster version for a unicodechar alone } +Function Pos (c : UnicodeChar; Const s : UnicodeString) : SizeInt; +begin + Pos:=0; + if length(S)>0 then + Pos:=JLString(s).indexOf(ord(c))+1; +end; + +(* +Function Pos (c : AnsiString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + result:=Pos(UnicodeString(c),s); + end; + + +Function Pos (c : ShortString; Const s : UnicodeString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + result:=Pos(UnicodeString(c),s); + end; + + +Function Pos (c : UnicodeString; Const s : AnsiString) : SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + result:=Pos(c,UnicodeString(s)); + 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 : UnicodeString) : SizeInt; +var + i: SizeInt; + wc : unicodechar; +begin + wc:=c; + result:=Pos(wc,s); +end; + + +(* +Procedure Delete (Var S : UnicodeString; Index,Size: SizeInt); +Var + LS : SizeInt; +begin + LS:=Length(S); + if (Index>LS) or (Index<=0) or (Size<=0) then + exit; + + UniqueString (S); + { (Size+Index) will overflow if Size=MaxInt. } + if Size>LS-Index then + Size:=LS-Index+1; + if Size<=LS-Index then + begin + Dec(Index); + Move(PUnicodeChar(S)[Index+Size],PUnicodeChar(S)[Index],(LS-Index-Size+1)*sizeof(UnicodeChar)); + end; + Setlength(s,LS-Size); +end; + + +Procedure Insert (Const Source : UnicodeString; Var S : UnicodeString; Index : SizeInt); +var + Temp : UnicodeString; + 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) := NewUnicodeString(Length(Source)+LS); + SetLength(Temp,Length(Source)+LS); + If Index>0 then + move (PUnicodeChar(S)^,PUnicodeChar(Temp)^,Index*sizeof(UnicodeChar)); + Move (PUnicodeChar(Source)^,PUnicodeChar(Temp)[Index],Length(Source)*sizeof(UnicodeChar)); + If (LS-Index)>0 then + Move(PUnicodeChar(S)[Index],PUnicodeChar(temp)[Length(Source)+index],(LS-Index)*sizeof(UnicodeChar)); + S:=Temp; +end; +*) + +Function UpCase(c:UnicodeChar):UnicodeChar; +begin + result:=JLCharacter.toUpperCase(c); +end; + + +function UpCase(const s : UnicodeString) : UnicodeString; +begin + result:=JLString(s).toUpperCase; +end; + +(* +Procedure SetString (Out S : UnicodeString; Buf : PUnicodeChar; Len : SizeInt); +begin + SetLength(S,Len); + If (Buf<>Nil) and (Len>0) then + Move (Buf[0],S[1],Len*sizeof(UnicodeChar)); +end; + + +Procedure SetString (Out S : UnicodeString; Buf : PChar; Len : SizeInt); +var + BufLen: SizeInt; +begin + SetLength(S,Len); + If (Buf<>Nil) and (Len>0) then + widestringmanager.Ansi2UnicodeMoveProc(Buf,S,Len); +end; + +{$ifndef FPUNONE} +Function fpc_Val_Real_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): ValReal; [public, alias:'FPC_VAL_REAL_UNICODESTR']; compilerproc; +Var + SS : String; +begin + fpc_Val_Real_UnicodeStr := 0; + if length(S) > 255 then + code := 256 + else + begin + SS := S; + Val(SS,fpc_Val_Real_UnicodeStr,code); + end; +end; +{$endif} + +function fpc_val_enum_unicodestr(str2ordindex:pointer;const s:unicodestring;out code:valsint):longint;compilerproc; + +var ss:shortstring; + +begin + if length(s)>255 then + code:=256 + else + begin + ss:=s; + val(ss,fpc_val_enum_unicodestr,code); + end; +end; + +Function fpc_Val_Currency_UnicodeStr(Const S : UnicodeString; out Code : ValSInt): Currency; [public, alias:'FPC_VAL_CURRENCY_UNICODESTR']; compilerproc; +Var + SS : String; +begin + if length(S) > 255 then + begin + fpc_Val_Currency_UnicodeStr:=0; + code := 256; + end + else + begin + SS := S; + Val(SS,fpc_Val_Currency_UnicodeStr,code); + end; +end; + + +Function fpc_Val_UInt_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): ValUInt; [public, alias:'FPC_VAL_UINT_UNICODESTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_UInt_UnicodeStr := 0; + if length(S) > 255 then + code := 256 + else + begin + SS := S; + Val(SS,fpc_Val_UInt_UnicodeStr,code); + end; +end; + + +Function fpc_Val_SInt_UnicodeStr (DestSize: SizeInt; Const S : UnicodeString; out Code : ValSInt): ValSInt; [public, alias:'FPC_VAL_SINT_UNICODESTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_SInt_UnicodeStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := S; + fpc_Val_SInt_UnicodeStr := int_Val_SInt_ShortStr(DestSize,SS,Code); + end; +end; + + +{$ifndef CPU64} + +Function fpc_Val_qword_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): qword; [public, alias:'FPC_VAL_QWORD_UNICODESTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_qword_UnicodeStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := S; + Val(SS,fpc_Val_qword_UnicodeStr,Code); + end; +end; + + +Function fpc_Val_int64_UnicodeStr (Const S : UnicodeString; out Code : ValSInt): Int64; [public, alias:'FPC_VAL_INT64_UNICODESTR']; compilerproc; +Var + SS : ShortString; +begin + fpc_Val_int64_UnicodeStr:=0; + if length(S)>255 then + code:=256 + else + begin + SS := S; + Val(SS,fpc_Val_int64_UnicodeStr,Code); + end; +end; + +{$endif CPU64} + + +{$ifndef FPUNONE} +procedure fpc_UnicodeStr_Float(d : ValReal;len,fr,rt : SizeInt;out s : UnicodeString);compilerproc; +var + ss : shortstring; +begin + str_real(len,fr,d,treal_type(rt),ss); + s:=ss; +end; +{$endif} + +procedure fpc_unicodestr_enum(ordinal,len:sizeint;typinfo,ord2strindex:pointer;out s:unicodestring);compilerproc; + +var ss:shortstring; + +begin + fpc_shortstr_enum(ordinal,len,typinfo,ord2strindex,ss); + s:=ss; +end; + +procedure fpc_unicodestr_bool(b : boolean;len:sizeint;out s:unicodestring);compilerproc; + +var ss:shortstring; + +begin + fpc_shortstr_bool(b,len,ss); + s:=ss; +end; + +{$ifdef FPC_HAS_STR_CURRENCY} +procedure fpc_UnicodeStr_Currency(c : Currency;len,fr : SizeInt;out s : UnicodeString);compilerproc; +var + ss : shortstring; +begin + str(c:len:fr,ss); + s:=ss; +end; +{$endif FPC_HAS_STR_CURRENCY} + +Procedure fpc_UnicodeStr_SInt(v : ValSint; Len : SizeInt; out S : UnicodeString);compilerproc; +Var + SS : ShortString; +begin + Str (v:Len,SS); + S:=SS; +end; + + +Procedure fpc_UnicodeStr_UInt(v : ValUInt;Len : SizeInt; out S : UnicodeString);compilerproc; +Var + SS : ShortString; +begin + str(v:Len,SS); + S:=SS; +end; + + +{$ifndef CPU64} + +Procedure fpc_UnicodeStr_Int64(v : Int64; Len : SizeInt; out S : UnicodeString);compilerproc; +Var + SS : ShortString; +begin + Str (v:Len,SS); + S:=SS; +end; + + +Procedure fpc_UnicodeStr_Qword(v : Qword;Len : SizeInt; out S : UnicodeString);compilerproc; +Var + SS : ShortString; +begin + str(v:Len,SS); + S:=SS; +end; + +{$endif CPU64} +*) + +(* +{ converts an utf-16 code point or surrogate pair to utf-32 } +function utf16toutf32(const S: UnicodeString; const index: SizeInt; out len: longint): UCS4Char; [public, alias: 'FPC_UTF16TOUTF32']; +var + w: unicodechar; +begin + { UTF-16 points in the range #$0-#$D7FF and #$E000-#$FFFF } + { are the same in UTF-32 } + w:=s[index]; + if (w<=#$d7ff) or + (w>=#$e000) then + begin + result:=UCS4Char(w); + len:=1; + end + { valid surrogate pair? } + else if (w<=#$dbff) and + { w>=#$d7ff check not needed, checked above } + (index=#$dc00) and + (s[index+1]<=#$dfff) then + { convert the surrogate pair to UTF-32 } + begin + result:=(UCS4Char(w)-$d800) shl 10 + (UCS4Char(s[index+1])-$dc00) + $10000; + len:=2; + end + else + { invalid surrogate -> do nothing } + begin + result:=UCS4Char(w); + len:=1; + end; +end; + + +function UnicodeToUtf8(Dest: PChar; Source: PUnicodeChar; MaxBytes: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + if assigned(Source) then + Result:=UnicodeToUtf8(Dest,MaxBytes,Source,IndexWord(Source^,-1,0)) + else + Result:=0; + end; + + +function UnicodeToUtf8(Dest: PChar; MaxDestBytes: SizeUInt; Source: PUnicodeChar; SourceChars: SizeUInt): SizeUInt; + var + i,j : SizeUInt; + w : word; + lw : longword; + len : longint; + begin + result:=0; + if source=nil then + exit; + i:=0; + j:=0; + if assigned(Dest) then + begin + while (i=MaxDestBytes then + break; + Dest[j]:=char($c0 or (w shr 6)); + Dest[j+1]:=char($80 or (w and $3f)); + inc(j,2); + end; + $800..$d7ff,$e000..$ffff: + begin + if j+2>=MaxDestBytes then + break; + Dest[j]:=char($e0 or (w shr 12)); + Dest[j+1]:=char($80 or ((w shr 6) and $3f)); + Dest[j+2]:=char($80 or (w and $3f)); + inc(j,3); + end; + $d800..$dbff: + {High Surrogates} + begin + if j+3>=MaxDestBytes then + break; + if (i= $dc00) and + (word(Source[i+1]) <= $dfff) then + begin + lw:=longword(utf16toutf32(Source[i] + Source[i+1], 1, len)); + Dest[j]:=char($f0 or (lw shr 18)); + Dest[j+1]:=char($80 or ((lw shr 12) and $3f)); + Dest[j+2]:=char($80 or ((lw shr 6) and $3f)); + Dest[j+3]:=char($80 or (lw and $3f)); + inc(j,4); + inc(i); + end; + end; + end; + inc(i); + end; + + if j>SizeUInt(MaxDestBytes-1) then + j:=MaxDestBytes-1; + + Dest[j]:=#0; + end + else + begin + while i= $dc00) and + (word(Source[i+1]) <= $dfff) then + begin + inc(j,4); + inc(i); + end; + end; + end; + inc(i); + end; + end; + result:=j+1; + end; + + +function Utf8ToUnicode(Dest: PUnicodeChar; Source: PChar; MaxChars: SizeInt): SizeInt;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + if assigned(Source) then + Result:=Utf8ToUnicode(Dest,MaxChars,Source,strlen(Source)) + else + Result:=0; + end; + + +function UTF8ToUnicode(Dest: PUnicodeChar; MaxDestChars: SizeUInt; Source: PChar; SourceBytes: SizeUInt): SizeUInt; + const + UNICODE_INVALID=63; + var + InputUTF8: SizeUInt; + IBYTE: BYTE; + OutputUnicode: SizeUInt; + PRECHAR: SizeUInt; + TempBYTE: BYTE; + CharLen: SizeUint; + LookAhead: SizeUInt; + UC: SizeUInt; + begin + if not assigned(Source) then + begin + result:=0; + exit; + end; + result:=SizeUInt(-1); + InputUTF8:=0; + OutputUnicode:=0; + PreChar:=0; + if Assigned(Dest) Then + begin + while (OutputUnicode13) and FALSE then + begin + //Expand to crlf, conform UTF-8. + //This procedure will break the memory alocation by + //FPC for the widestring, so never use it. Condition never true due the "and FALSE". + if OutputUnicode+10 do + begin + TempBYTE:=(TempBYTE shl 1) and $FE; + inc(CharLen); + end; + //Test for the "CharLen" conforms UTF-8 string + //This means the 10xxxxxx pattern. + if SizeUInt(InputUTF8+CharLen-1)>SourceBytes then + begin + //Insuficient chars in string to decode + //UTF-8 array. Fallback to single char. + CharLen:= 1; + end; + for LookAhead := 1 to CharLen-1 do + begin + if ((byte(Source[InputUTF8+LookAhead]) and $80)<>$80) or + ((byte(Source[InputUTF8+LookAhead]) and $40)<>$00) then + begin + //Invalid UTF-8 sequence, fallback. + CharLen:= LookAhead; + break; + end; + end; + UC:=$FFFF; + case CharLen of + 1: begin + //Not valid UTF-8 sequence + UC:=UNICODE_INVALID; + end; + 2: begin + //Two bytes UTF, convert it + UC:=(byte(Source[InputUTF8]) and $1F) shl 6; + UC:=UC or (byte(Source[InputUTF8+1]) and $3F); + if UC <= $7F then + begin + //Invalid UTF sequence. + UC:=UNICODE_INVALID; + end; + end; + 3: begin + //Three bytes, convert it to unicode + UC:= (byte(Source[InputUTF8]) and $0F) shl 12; + UC:= UC or ((byte(Source[InputUTF8+1]) and $3F) shl 6); + UC:= UC or ((byte(Source[InputUTF8+2]) and $3F)); + if (UC <= $7FF) or (UC >= $FFFE) or ((UC >= $D800) and (UC <= $DFFF)) then + begin + //Invalid UTF-8 sequence + UC:= UNICODE_INVALID; + End; + end; + 4: begin + //Four bytes, convert it to two unicode characters + UC:= (byte(Source[InputUTF8]) and $07) shl 18; + UC:= UC or ((byte(Source[InputUTF8+1]) and $3F) shl 12); + UC:= UC or ((byte(Source[InputUTF8+2]) and $3F) shl 6); + UC:= UC or ((byte(Source[InputUTF8+3]) and $3F)); + if (UC < $10000) or (UC > $10FFFF) then + begin + UC:= UNICODE_INVALID; + end + else + begin + { only store pair if room } + dec(UC,$10000); + if (OutputUnicode 0 then + begin + PreChar:=UC; + Dest[OutputUnicode]:=WideChar(UC); + inc(OutputUnicode); + end; + InputUTF8:= InputUTF8 + CharLen; + end; + end; + Result:=OutputUnicode+1; + end + else + begin + while (InputUTF813) and FALSE then + begin + //Expand to crlf, conform UTF-8. + //This procedure will break the memory alocation by + //FPC for the widestring, so never use it. Condition never true due the "and FALSE". + inc(OutputUnicode,2); + PreChar:=10; + end + else + begin + inc(OutputUnicode); + PreChar:=IBYTE; + end; + end + else + begin + inc(OutputUnicode); + PreChar:=IBYTE; + end; + inc(InputUTF8); + end + else + begin + TempByte:=IBYTE; + CharLen:=0; + while (TempBYTE and $80)<>0 do + begin + TempBYTE:=(TempBYTE shl 1) and $FE; + inc(CharLen); + end; + //Test for the "CharLen" conforms UTF-8 string + //This means the 10xxxxxx pattern. + if SizeUInt(InputUTF8+CharLen-1)>SourceBytes then + begin + //Insuficient chars in string to decode + //UTF-8 array. Fallback to single char. + CharLen:= 1; + end; + for LookAhead := 1 to CharLen-1 do + begin + if ((byte(Source[InputUTF8+LookAhead]) and $80)<>$80) or + ((byte(Source[InputUTF8+LookAhead]) and $40)<>$00) then + begin + //Invalid UTF-8 sequence, fallback. + CharLen:= LookAhead; + break; + end; + end; + UC:=$FFFF; + case CharLen of + 1: begin + //Not valid UTF-8 sequence + UC:=UNICODE_INVALID; + end; + 2: begin + //Two bytes UTF, convert it + UC:=(byte(Source[InputUTF8]) and $1F) shl 6; + UC:=UC or (byte(Source[InputUTF8+1]) and $3F); + if UC <= $7F then + begin + //Invalid UTF sequence. + UC:=UNICODE_INVALID; + end; + end; + 3: begin + //Three bytes, convert it to unicode + UC:= (byte(Source[InputUTF8]) and $0F) shl 12; + UC:= UC or ((byte(Source[InputUTF8+1]) and $3F) shl 6); + UC:= UC or ((byte(Source[InputUTF8+2]) and $3F)); + If (UC <= $7FF) or (UC >= $FFFE) or ((UC >= $D800) and (UC <= $DFFF)) then + begin + //Invalid UTF-8 sequence + UC:= UNICODE_INVALID; + end; + end; + 4: begin + //Four bytes, convert it to two unicode characters + UC:= (byte(Source[InputUTF8]) and $07) shl 18; + UC:= UC or ((byte(Source[InputUTF8+1]) and $3F) shl 12); + UC:= UC or ((byte(Source[InputUTF8+2]) and $3F) shl 6); + UC:= UC or ((byte(Source[InputUTF8+3]) and $3F)); + if (UC < $10000) or (UC > $10FFFF) then + UC:= UNICODE_INVALID + else + { extra character character } + inc(OutputUnicode); + end; + 5,6,7: begin + //Invalid UTF8 to unicode conversion, + //mask it as invalid UNICODE too. + UC:=UNICODE_INVALID; + end; + end; + if CharLen > 0 then + begin + PreChar:=UC; + inc(OutputUnicode); + end; + InputUTF8:= InputUTF8 + CharLen; + end; + end; + Result:=OutputUnicode+1; + end; + end; + + +function UTF8Encode(const s : Ansistring) : UTF8String; inline; + begin + Result:=UTF8Encode(UnicodeString(s)); + end; + + +function UTF8Encode(const s : UnicodeString) : UTF8String; + var + i : SizeInt; + hs : UTF8String; + begin + result:=''; + if s='' then + exit; + SetLength(hs,length(s)*3); + i:=UnicodeToUtf8(pchar(hs),length(hs)+1,PUnicodeChar(s),length(s)); + if i>0 then + begin + SetLength(hs,i-1); + result:=hs; + end; + end; + + +function UTF8Decode(const s : UTF8String): UnicodeString; + var + i : SizeInt; + hs : UnicodeString; + begin + result:=''; + if s='' then + exit; + SetLength(hs,length(s)); + i:=Utf8ToUnicode(PUnicodeChar(hs),length(hs)+1,pchar(s),length(s)); + if i>0 then + begin + SetLength(hs,i-1); + result:=hs; + end; + end; + + +function AnsiToUtf8(const s : ansistring): UTF8String;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + Result:=Utf8Encode(s); + end; + + +function Utf8ToAnsi(const s : UTF8String) : ansistring;{$ifdef SYSTEMINLINE}inline;{$endif} + begin + Result:=Utf8Decode(s); + end; + + +function UnicodeStringToUCS4String(const s : UnicodeString) : UCS4String; + var + i, slen, + destindex : SizeInt; + len : longint; + begin + slen:=length(s); + setlength(result,slen+1); + i:=1; + destindex:=0; + while (i<=slen) do + begin + result[destindex]:=utf16toutf32(s,i,len); + inc(destindex); + inc(i,len); + end; + { destindex <= slen (surrogate pairs may have been merged) } + { destindex+1 for terminating #0 (dynamic arrays are } + { implicitely filled with zero) } + setlength(result,destindex+1); + end; + + +{ concatenates an utf-32 char to a unicodestring. S *must* be unique when entering. } +procedure ConcatUTF32ToUnicodeStr(const nc: UCS4Char; var S: UnicodeString; var index: SizeInt); +var + p : PUnicodeChar; +begin + { if nc > $ffff, we need two places } + if (index+ord(nc > $ffff)>length(s)) then + if (length(s) < 10*256) then + setlength(s,length(s)+10) + else + setlength(s,length(s)+length(s) shr 8); + { we know that s is unique -> avoid uniquestring calls} + p:=@s[index]; + if (nc<$ffff) then + begin + p^:=unicodechar(nc); + inc(index); + end + else if (dword(nc)<=$10ffff) then + begin + p^:=unicodechar((nc - $10000) shr 10 + $d800); + (p+1)^:=unicodechar((nc - $10000) and $3ff + $dc00); + inc(index,2); + end + else + { invalid code point } + begin + p^:='?'; + inc(index); + end; +end; + + +function UCS4StringToUnicodeString(const s : UCS4String) : UnicodeString; + var + i : SizeInt; + resindex : SizeInt; + begin + { skip terminating #0 } + SetLength(result,length(s)-1); + resindex:=1; + for i:=0 to high(s)-1 do + ConcatUTF32ToUnicodeStr(s[i],result,resindex); + { adjust result length (may be too big due to growing } + { for surrogate pairs) } + setlength(result,resindex-1); + end; + + +function WideStringToUCS4String(const s : WideString) : UCS4String; + var + i, slen, + destindex : SizeInt; + len : longint; + begin + slen:=length(s); + setlength(result,slen+1); + i:=1; + destindex:=0; + while (i<=slen) do + begin + result[destindex]:=utf16toutf32(s,i,len); + inc(destindex); + inc(i,len); + end; + { destindex <= slen (surrogate pairs may have been merged) } + { destindex+1 for terminating #0 (dynamic arrays are } + { implicitely filled with zero) } + setlength(result,destindex+1); + end; + + +{ concatenates an utf-32 char to a widestring. S *must* be unique when entering. } +procedure ConcatUTF32ToWideStr(const nc: UCS4Char; var S: WideString; var index: SizeInt); +var + p : PWideChar; +begin + { if nc > $ffff, we need two places } + if (index+ord(nc > $ffff)>length(s)) then + if (length(s) < 10*256) then + setlength(s,length(s)+10) + else + setlength(s,length(s)+length(s) shr 8); + { we know that s is unique -> avoid uniquestring calls} + p:=@s[index]; + if (nc<$ffff) then + begin + p^:=widechar(nc); + inc(index); + end + else if (dword(nc)<=$10ffff) then + begin + p^:=widechar((nc - $10000) shr 10 + $d800); + (p+1)^:=widechar((nc - $10000) and $3ff + $dc00); + inc(index,2); + end + else + { invalid code point } + begin + p^:='?'; + inc(index); + end; +end; + + +function UCS4StringToWideString(const s : UCS4String) : WideString; + var + i : SizeInt; + resindex : SizeInt; + begin + { skip terminating #0 } + SetLength(result,length(s)-1); + resindex:=1; + for i:=0 to high(s)-1 do + ConcatUTF32ToWideStr(s[i],result,resindex); + { adjust result length (may be too big due to growing } + { for surrogate pairs) } + setlength(result,resindex-1); + end; + + +const + SNoUnicodestrings = 'This binary has no unicodestrings support compiled in.'; + SRecompileWithUnicodestrings = 'Recompile the application with a unicodestrings-manager in the program uses clause.'; +*) + +function CompareUnicodeString(const s1, s2 : UnicodeString) : PtrInt; + begin + widestringmanager.collator.setStrength(JTCollator.IDENTICAL); + result:=widestringmanager.collator.compare(s1,s2); + end; + + +function CompareTextUnicodeString(const s1, s2 : UnicodeString): PtrInt; + begin + widestringmanager.collator.setStrength(JTCollator.TERTIARY); + result:=widestringmanager.collator.compare(s1,s2); + end; + +constructor TUnicodeStringManager.create; + begin + end; + + +procedure initunicodestringmanager; + begin + widestringmanager:=TUnicodeStringManager.create; + widestringmanager.collator:=JTCollator.getInstance; + end; +