+ full support for sets on the JVM target

o sets of enums are handled as JUEnumSet instances, others as JUBitSet
     derivatives (both smallsets and varsets, to make interoperability with
     Java easier)
   o special handling of set constants: these have to be constructed at run
     time. In case of constants in the code, create an internal constsym to
     represent them. These and regular constsyms are then aliased by an
     another internal staticvarsym that is used to initialise them in the
     unit initialisation code.
   o until they are constructed at run time, set constants are encoded as
     constant Java strings (with the characters containing the set bits)
   o hlcgobj conversion of tcginnode.pass_generate_code() for the genjumps
     part (that's the only part of the generic code that's used by the JVM
     target)
   o as far as explicit typecasting support is concerned, currently the
     following ones are supported (both from/to setdefs): ordinal types,
     enums, any other set types (whose size is the same on native targets)
   o enum setdefs also emit signatures
   o overloading routines for different ordinal set types, or for different
     enum set types, is not supported on the JVM target

git-svn-id: branches/jvmbackend@18662 -
This commit is contained in:
Jonas Maebe 2011-08-20 08:22:22 +00:00
parent 9ebf623895
commit 37aa2d8443
32 changed files with 1815 additions and 325 deletions

3
.gitattributes vendored
View File

@ -229,6 +229,7 @@ compiler/jvm/njvmld.pas svneol=native#text/plain
compiler/jvm/njvmmat.pas svneol=native#text/plain
compiler/jvm/njvmmem.pas svneol=native#text/plain
compiler/jvm/njvmset.pas svneol=native#text/plain
compiler/jvm/njvmtcon.pas svneol=native#text/plain
compiler/jvm/njvmutil.pas svneol=native#text/plain
compiler/jvm/rgcpu.pas svneol=native#text/plain
compiler/jvm/rjvmcon.inc svneol=native#text/plain
@ -7364,6 +7365,8 @@ rtl/java/jint64.inc svneol=native#text/plain
rtl/java/jmathh.inc svneol=native#text/plain
rtl/java/jrec.inc svneol=native#text/plain
rtl/java/jrech.inc svneol=native#text/plain
rtl/java/jset.inc svneol=native#text/plain
rtl/java/jseth.inc svneol=native#text/plain
rtl/java/objpas.pp svneol=native#text/plain
rtl/java/rtl.cfg svneol=native#text/plain
rtl/java/rtti.inc svneol=native#text/plain

View File

@ -782,9 +782,9 @@ implementation
result:='';
else
begin
{ enums are initialized as typed constants }
{ enums and sets are initialized as typed constants }
if not assigned(csym.constdef) or
(csym.constdef.typ<>enumdef) then
not(csym.constdef.typ in [enumdef,setdef]) then
result:=' = '+ConstValue(csym)
end;
end;

View File

@ -35,6 +35,6 @@ implementation
njvmadd,njvmcal,njvmmat,njvmcnv,njvmcon,njvminl,njvmmem,njvmflw,njvmld,
njvmset
{ these are not really nodes }
,rgcpu,tgcpu,njvmutil;
,rgcpu,tgcpu,njvmutil,njvmtcon;
end.

View File

@ -187,6 +187,7 @@ uses
{ concatcopy helpers }
procedure concatcopy_normal_array(list: TAsmList; size: tdef; const source, dest: treference);
procedure concatcopy_record(list: TAsmList; size: tdef; const source, dest: treference);
procedure concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
procedure concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
{ generate a call to a routine in the system unit }
@ -252,13 +253,9 @@ implementation
case def.typ of
{ records and enums are implemented via classes }
recorddef,
enumdef:
result:=R_ADDRESSREGISTER;
enumdef,
setdef:
if is_smallset(def) then
result:=R_INTREGISTER
else
result:=R_ADDRESSREGISTER;
result:=R_ADDRESSREGISTER;
{ shortstrings are implemented via classes }
else if is_shortstring(def) or
{ voiddef can only be typecasted into (implicit) pointers }
@ -644,22 +641,32 @@ implementation
{ all dimensions are removed from the stack, an array reference is
added }
decstack(list,initdim-1);
{ in case of an array of records or shortstrings, initialise }
{ in case of an array of records, sets or shortstrings, initialise }
elemdef:=tarraydef(arrdef).elementdef;
for i:=1 to pred(initdim) do
elemdef:=tarraydef(elemdef).elementdef;
if (elemdef.typ=recorddef) or
if (elemdef.typ in [recorddef,setdef]) or
is_shortstring(elemdef) then
begin
{ duplicate array reference }
{ duplicate array/string/set instance }
list.concat(taicpu.op_none(a_dup));
incstack(list,1);
a_load_const_stack(list,s32inttype,initdim-1,R_INTREGISTER);
if elemdef.typ=recorddef then
if elemdef.typ in [recorddef,setdef,procvardef] then
begin
tg.gethltemp(list,elemdef,elemdef.size,tt_persistent,recref);
a_load_ref_stack(list,elemdef,recref,prepare_stack_for_ref(list,recref,false));
g_call_system_proc(list,'fpc_initialize_array_record');
case elemdef.typ of
recorddef:
g_call_system_proc(list,'fpc_initialize_array_record');
setdef:
begin
if tsetdef(elemdef).elementdef.typ=enumdef then
g_call_system_proc(list,'fpc_initialize_array_enumset')
else
g_call_system_proc(list,'fpc_initialize_array_bitset')
end
end;
tg.ungettemp(list,recref);
end
else
@ -1135,6 +1142,11 @@ implementation
end;
recorddef:
procname:='FPC_COPY_JRECORD_ARRAY';
setdef:
if tsetdef(eledef).elementdef.typ=enumdef then
procname:='FPC_COPY_JENUMSET_ARRAY'
else
procname:='FPC_COPY_JBITSET_ARRAY';
floatdef:
procname:='FPC_COPY_SHALLOW_ARRAY';
stringdef:
@ -1142,7 +1154,6 @@ implementation
procname:='FPC_COPY_JSHORTSTRING_ARRAY'
else
procname:='FPC_COPY_SHALLOW_ARRAY';
setdef,
variantdef:
begin
{$ifndef nounsupported}
@ -1198,6 +1209,20 @@ implementation
end;
procedure thlcgjvm.concatcopy_set(list: TAsmList; size: tdef; const source, dest: treference);
begin
a_load_ref_stack(list,size,source,prepare_stack_for_ref(list,source,false));
a_load_ref_stack(list,size,dest,prepare_stack_for_ref(list,dest,false));
{ call set copy helper }
if tsetdef(size).elementdef.typ=enumdef then
g_call_system_proc(list,'fpc_enumset_copy')
else
g_call_system_proc(list,'fpc_bitset_copy');
{ both parameters are removed, no function result }
decstack(list,2);
end;
procedure thlcgjvm.concatcopy_shortstring(list: TAsmList; size: tdef; const source, dest: treference);
var
srsym: tsym;
@ -1238,6 +1263,11 @@ implementation
concatcopy_record(list,size,source,dest);
handled:=true;
end;
setdef:
begin
concatcopy_set(list,size,source,dest);
handled:=true;
end;
stringdef:
begin
if is_shortstring(size) then
@ -1324,10 +1354,7 @@ implementation
opc:=a_ireturn;
end;
setdef:
if is_smallset(retdef) then
opc:=a_ireturn
else
opc:=a_areturn;
opc:=a_areturn;
floatdef:
case tfloatdef(retdef).floattype of
s32real:
@ -1378,7 +1405,7 @@ implementation
procedure thlcgjvm.g_array_rtti_helper(list: TAsmList; t: tdef; const ref: treference; const highloc: tlocation; const name: string);
var
normaldim: longint;
recref: treference;
eleref: treference;
begin
{ only in case of initialisation, we have to set all elements to "empty" }
if name<>'FPC_INITIALIZE_ARRAY' then
@ -1402,12 +1429,18 @@ implementation
g_call_system_proc(list,'fpc_initialize_array_ansistring')
else if is_dynamic_array(t) then
g_call_system_proc(list,'fpc_initialize_array_dynarr')
else if is_record(t) then
else if is_record(t) or
(t.typ=setdef) then
begin
tg.gethltemp(list,t,t.size,tt_persistent,recref);
a_load_ref_stack(list,t,recref,prepare_stack_for_ref(list,recref,false));
g_call_system_proc(list,'fpc_initialize_array_record');
tg.ungettemp(list,recref);
tg.gethltemp(list,t,t.size,tt_persistent,eleref);
a_load_ref_stack(list,t,eleref,prepare_stack_for_ref(list,eleref,false));
if is_record(t) then
g_call_system_proc(list,'fpc_initialize_array_record')
else if tsetdef(t).elementdef.typ=enumdef then
g_call_system_proc(list,'fpc_initialize_array_enumset')
else
g_call_system_proc(list,'fpc_initialize_array_bitset');
tg.ungettemp(list,eleref);
end
else
internalerror(2011031901);
@ -1851,6 +1884,11 @@ implementation
vs:=tabstractvarsym(st.symlist[i]);
if sp_internal in vs.symoptions then
continue;
{ vo_is_external and vo_has_local_copy means a staticvarsym that is
alias for a constsym, whose sole purpose is for allocating and
intialising the constant }
if [vo_is_external,vo_has_local_copy]*vs.varoptions=[vo_is_external] then
continue;
if not jvmimplicitpointertype(vs.vardef) then
continue;
allocate_implicit_struct_with_base_ref(list,vs,ref);

View File

@ -37,6 +37,7 @@ interface
function pass_1: tnode;override;
protected
function first_addstring: tnode; override;
function jvm_first_addset: tnode;
function cmpnode2signedtopcmp: TOpCmp;
@ -46,7 +47,6 @@ interface
procedure second_addfloat;override;
procedure second_cmpfloat;override;
procedure second_cmpboolean;override;
procedure second_cmpsmallset;override;
procedure second_cmp64bit;override;
procedure second_add64bit; override;
procedure second_cmpordinal;override;
@ -56,13 +56,14 @@ interface
uses
systems,
cutils,verbose,constexp,
cutils,verbose,constexp,globtype,
symconst,symtable,symdef,
paramgr,procinfo,
paramgr,procinfo,pass_1,
aasmtai,aasmdata,aasmcpu,defutil,
hlcgobj,hlcgcpu,cgutils,
cpupara,
ncon,nset,nadd,ncal,ncnv,
nbas,ncon,nset,nadd,ncal,ncnv,nld,nmat,nmem,
njvmcon,
cgobj;
{*****************************************************************************
@ -85,6 +86,13 @@ interface
inserttypeconv_explicit(left,s32inttype);
inserttypeconv_explicit(right,s32inttype);
end;
{ special handling for sets: all sets are JUBitSet/JUEnumSet on the JVM
target to ease interoperability with Java code }
if left.resultdef.typ=setdef then
begin
result:=jvm_first_addset;
exit;
end;
result:=inherited pass_1;
if expectloc=LOC_FLAGS then
expectloc:=LOC_JUMP;
@ -156,6 +164,225 @@ interface
end;
end;
function tjvmaddnode.jvm_first_addset: tnode;
procedure call_set_helper_paras(const n : string; isenum: boolean; paras: tcallparanode);
var
block: tblocknode;
stat: tstatementnode;
temp: ttempcreatenode;
begin
result:=ccallnode.createinternmethod(left,'CLONE',nil);
if isenum then
inserttypeconv_explicit(result,java_juenumset)
else
inserttypeconv_explicit(result,java_jubitset);
if isenum then
begin
{ all enum instance methods return a boolean, while we are
interested in the resulting set }
block:=internalstatements(stat);
temp:=ctempcreatenode.create(java_juenumset,4,tt_persistent,true);
addstatement(stat,temp);
addstatement(stat,cassignmentnode.create(
ctemprefnode.create(temp),result));
addstatement(stat,ccallnode.createinternmethod(
ctemprefnode.create(temp),n,paras));
addstatement(stat,ctempdeletenode.create_normal_temp(temp));
addstatement(stat,ctemprefnode.create(temp));
result:=block;
end
else
result:=ccallnode.createinternmethod(result,n,paras);
end;
procedure call_set_helper(const n: string; isenum: boolean);
begin
call_set_helper_paras(n,isenum,ccallparanode.create(right,nil));
end;
var
procname: string;
tmpn: tnode;
paras: tcallparanode;
isenum: boolean;
begin
isenum:=
(assigned(tsetdef(left.resultdef).elementdef) and
(tsetdef(left.resultdef).elementdef.typ=enumdef)) or
((right.nodetype=setelementn) and
(tsetelementnode(right).left.resultdef.typ=enumdef)) or
((right.resultdef.typ=setdef) and
assigned(tsetdef(right.resultdef).elementdef) and
(tsetdef(right.resultdef).elementdef.typ=enumdef));
{ don't destroy optimization opportunity }
if not((nodetype=addn) and
(right.nodetype=setelementn) and
is_emptyset(left)) then
begin
left:=caddrnode.create_internal(left);
include(left.flags,nf_typedaddr);
if isenum then
begin
inserttypeconv_explicit(left,java_juenumset);
if right.resultdef.typ=setdef then
begin
right:=caddrnode.create_internal(right);
include(right.flags,nf_typedaddr);
inserttypeconv_explicit(right,java_juenumset);
end;
end
else
begin
inserttypeconv_explicit(left,java_jubitset);
if right.resultdef.typ=setdef then
begin
right:=caddrnode.create_internal(right);
include(right.flags,nf_typedaddr);
inserttypeconv_explicit(right,java_jubitset);
end;
end;
end
else
tjvmsetconstnode(left).setconsttype:=sct_notransform;
firstpass(left);
firstpass(right);
case nodetype of
equaln,unequaln,lten,gten:
begin
case nodetype of
equaln,unequaln:
procname:='EQUALS';
lten,gten:
begin
{ (left <= right) = (right >= left) }
if nodetype=lten then
begin
tmpn:=left;
left:=right;
right:=tmpn;
end;
procname:='CONTAINSALL'
end;
end;
result:=ccallnode.createinternmethod(left,procname,ccallparanode.create(right,nil));
{ for an unequaln, we have to negate the result of equals }
if nodetype=unequaln then
result:=cnotnode.create(result);
end;
addn:
begin
{ optimize first loading of a set }
if (right.nodetype=setelementn) and
is_emptyset(left) then
begin
paras:=nil;
procname:='OF';
if isenum then
begin
inserttypeconv_explicit(tsetelementnode(right).left,tenumdef(tsetelementnode(right).left.resultdef).getbasedef.classdef);
result:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
end
else
begin
{ for boolean, char, etc }
inserttypeconv_explicit(tsetelementnode(right).left,s32inttype);
result:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
end;
paras:=ccallparanode.create(tsetelementnode(right).left,nil);
tsetelementnode(right).left:=nil;
if assigned(tsetelementnode(right).right) then
begin
procname:='RANGE';
if isenum then
begin
inserttypeconv_explicit(tsetelementnode(right).right,tenumdef(tsetelementnode(right).right.resultdef).getbasedef.classdef);
end
else
begin
inserttypeconv_explicit(tsetelementnode(right).right,s32inttype);
end;
paras:=ccallparanode.create(tsetelementnode(right).right,paras);
tsetelementnode(right).right:=nil;
end;
right.free;
result:=ccallnode.createinternmethod(result,procname,paras)
end
else
begin
if right.nodetype=setelementn then
begin
paras:=nil;
{ get a copy of left to add to }
procname:='ADD';
if isenum then
begin
inserttypeconv_explicit(tsetelementnode(right).left,tenumdef(tsetelementnode(right).left.resultdef).getbasedef.classdef);
end
else
begin
{ for boolean, char, etc }
inserttypeconv_explicit(tsetelementnode(right).left,s32inttype);
end;
paras:=ccallparanode.create(tsetelementnode(right).left,paras);
tsetelementnode(right).left:=nil;
if assigned(tsetelementnode(right).right) then
begin
procname:='ADDALL';
{ create a set containing the range via the class
factory method, then add all of its elements }
if isenum then
begin
inserttypeconv_explicit(tsetelementnode(right).right,tenumdef(tsetelementnode(right).right.resultdef).getbasedef.classdef);
tmpn:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
end
else
begin
inserttypeconv_explicit(tsetelementnode(right).right,s32inttype);
tmpn:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
end;
paras:=ccallparanode.create(ccallnode.createinternmethod(tmpn,'RANGE',ccallparanode.create(tsetelementnode(right).right,paras)),nil);
tsetelementnode(right).right:=nil;
end;
call_set_helper_paras(procname,isenum,paras);
end
else
call_set_helper('ADDALL',isenum)
end
end;
subn:
call_set_helper('REMOVEALL',isenum);
symdifn:
if isenum then
begin
{ "s1 xor s2" is the same as "(s1 + s2) - (s1 * s2)"
-> call helper to prevent double evaluations }
result:=ccallnode.createintern('fpc_enumset_symdif',
ccallparanode.create(right,ccallparanode.create(left,nil)));
left:=nil;
right:=nil;
end
else
call_set_helper('SYMDIF',isenum);
muln:
call_set_helper('RETAINALL',isenum)
else
internalerror(2011062807);
end;
{ convert helper result back to original set type for further expression
evaluation }
if not is_boolean(resultdef) then
begin
inserttypeconv_explicit(result,getpointerdef(resultdef));
result:=cderefnode.create(result);
end;
{ left and right are reused as parameters }
left:=nil;
right:=nil;
end;
function tjvmaddnode.cmpnode2signedtopcmp: TOpCmp;
begin
case nodetype of
@ -323,38 +550,6 @@ interface
end;
procedure tjvmaddnode.second_cmpsmallset;
begin
if (nodetype in [equaln,unequaln]) then
begin
second_generic_compare;
exit;
end;
case nodetype of
lten,gten:
begin
pass_left_right;
If (not(nf_swapped in flags) and
(nodetype=lten)) or
((nf_swapped in flags) and
(nodetype=gten)) then
swapleftright;
location_reset(location,LOC_JUMP,OS_NO);
// now we have to check whether left >= right:
// (right and not(left)=0)
thlcgjvm(hlcg).a_load_loc_stack(current_asmdata.CurrAsmList,left.resultdef,left.location);
thlcgjvm(hlcg).a_op_reg_stack(current_asmdata.CurrAsmList,OP_NOT,left.resultdef,NR_NO);
thlcgjvm(hlcg).a_op_loc_stack(current_asmdata.CurrAsmList,OP_AND,right.resultdef,right.location);
current_asmdata.CurrAsmList.concat(taicpu.op_sym(a_ifeq,current_procinfo.CurrTrueLabel));
thlcgjvm(hlcg).decstack(current_asmdata.CurrAsmList,1);
hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
end;
else
internalerror(2011010414);
end;
end;
procedure tjvmaddnode.second_cmp64bit;
begin
second_generic_compare;

View File

@ -35,6 +35,7 @@ interface
function typecheck_char_to_string: tnode; override;
function pass_1: tnode; override;
function simplify(forinline: boolean): tnode; override;
function first_set_to_set : tnode;override;
procedure second_int_to_int;override;
{ procedure second_string_to_string;override; }
@ -88,7 +89,7 @@ interface
implementation
uses
verbose,globals,globtype,
verbose,globals,globtype,constexp,
symconst,symdef,symsym,symtable,aasmbase,aasmdata,
defutil,defcmp,jvmdef,
cgbase,cgutils,pass_1,pass_2,
@ -229,6 +230,71 @@ implementation
end;
function tjvmtypeconvnode.first_set_to_set: tnode;
var
setclassdef: tdef;
helpername: string;
begin
result:=nil;
if (left.nodetype=setconstn) then
result:=inherited
{ on native targets, only the binary layout has to match. Here, both
sets also have to be either of enums or ordinals, and in case of
enums they have to be of the same base type }
else if (tsetdef(left.resultdef).elementdef.typ=enumdef)=(tsetdef(resultdef).elementdef.typ=enumdef) and
((tsetdef(left.resultdef).elementdef.typ<>enumdef) or
(tenumdef(tsetdef(left.resultdef).elementdef).getbasedef=tenumdef(tsetdef(resultdef).elementdef).getbasedef)) and
(tsetdef(left.resultdef).setbase=tsetdef(resultdef).setbase) and
(left.resultdef.size=resultdef.size) then
begin
result:=left;
left:=nil;
end
else
begin
{ 'deep' conversion }
if tsetdef(resultdef).elementdef.typ<>enumdef then
begin
if tsetdef(left.resultdef).elementdef.typ<>enumdef then
helpername:='fpc_bitset_to_bitset'
else
helpername:='fpc_enumset_to_bitset';
result:=ccallnode.createintern(helpername,ccallparanode.create(
genintconstnode(tsetdef(resultdef).setbase), ccallparanode.create(
genintconstnode(tsetdef(left.resultdef).setbase),
ccallparanode.create(left,nil))));
end
else
begin
if tsetdef(left.resultdef).elementdef.typ<>enumdef then
begin
helpername:='fpcBitSetToEnumSet';
setclassdef:=java_jubitset;
end
else
begin
helpername:='fpcEnumSetToEnumSet';
setclassdef:=java_juenumset;
end;
left:=caddrnode.create_internal(left);
include(left.flags,nf_typedaddr);
inserttypeconv_explicit(left,setclassdef);
result:=ccallnode.createinternmethod(
cloadvmtaddrnode.create(ctypenode.create(setclassdef)),
helpername,ccallparanode.create(
genintconstnode(tsetdef(resultdef).setbase), ccallparanode.create(
genintconstnode(tsetdef(left.resultdef).setbase),
ccallparanode.create(left,nil))));
end;
inserttypeconv_explicit(result,getpointerdef(resultdef));
result:=cderefnode.create(result);
{ reused }
left:=nil;
end;
end;
{*****************************************************************************
SecondTypeConv
*****************************************************************************}
@ -587,6 +653,68 @@ implementation
left:=nil;
end;
function from_set_explicit_typecast: tnode;
var
helpername: string;
setconvdef: tdef;
begin
if tsetdef(left.resultdef).elementdef.typ=enumdef then
begin
setconvdef:=java_juenumset;
helpername:='fpc_enumset_to_'
end
else
begin
setconvdef:=java_jubitset;
helpername:='fpc_bitset_to_'
end;
if left.resultdef.size<=4 then
helpername:=helpername+'int'
else
helpername:=helpername+'long';
result:=ccallnode.createintern(helpername,ccallparanode.create(
genintconstnode(left.resultdef.size),ccallparanode.create(genintconstnode(tsetdef(left.resultdef).setbase),
ccallparanode.create(ctypeconvnode.create_explicit(left,setconvdef),nil))));
left:=nil;
end;
function to_set_explicit_typecast: tnode;
var
enumclassdef: tobjectdef;
mp: tnode;
helpername: string;
begin
if tsetdef(resultdef).elementdef.typ=enumdef then
begin
inserttypeconv_explicit(left,s64inttype);
enumclassdef:=tenumdef(tsetdef(resultdef).elementdef).getbasedef.classdef;
mp:=cloadvmtaddrnode.create(ctypenode.create(enumclassdef));
helpername:='fpcLongToEnumSet';
{ enumclass.fpcLongToEnumSet(left,setbase,setsize) }
result:=ccallnode.createinternmethod(mp,helpername,
ccallparanode.create(genintconstnode(resultdef.size),
ccallparanode.create(genintconstnode(tsetdef(resultdef).setbase),
ccallparanode.create(left,nil))));
end
else
begin
if left.resultdef.size<=4 then
begin
helpername:='fpc_int_to_bitset';
inserttypeconv_explicit(left,s32inttype);
end
else
begin
helpername:='fpc_long_to_bitset';
inserttypeconv_explicit(left,s64inttype);
end;
result:=ccallnode.createintern(helpername,
ccallparanode.create(genintconstnode(resultdef.size),
ccallparanode.create(genintconstnode(tsetdef(resultdef).setbase),
ccallparanode.create(left,nil))));
end;
end;
function ptr_no_typecheck_required(fromdef, todef: tdef): boolean;
function check_type_equality(def1,def2: tdef): boolean;
@ -603,6 +731,23 @@ implementation
if is_shortstring(tpointerdef(def1).pointeddef) and
(def2=java_shortstring) then
exit;
{ pointer-to-set to JUEnumSet/JUBitSet }
if (tpointerdef(def1).pointeddef.typ=setdef) then
begin
if not assigned(tsetdef(tpointerdef(def1).pointeddef).elementdef) then
begin
if (def2=java_jubitset) or
(def2=java_juenumset) then
exit;
end
else if tsetdef(tpointerdef(def1).pointeddef).elementdef.typ=enumdef then
begin
if def2=java_juenumset then
exit;
end
else if def2=java_jubitset then
exit;
end;
end;
result:=false;
end;
@ -841,14 +986,41 @@ implementation
end
end;
{$ifndef nounsupported}
if (left.resultdef.typ in [orddef,enumdef,setdef]) and
(resultdef.typ in [orddef,enumdef,setdef]) then
{ sets }
if (left.resultdef.typ=setdef) or
(resultdef.typ=setdef) then
begin
result:=false;
exit;
{ set -> ord/enum/other-set-type }
if (resultdef.typ in [orddef,enumdef]) then
begin
if not check_only then
begin
resnode:=from_set_explicit_typecast;
{ convert to desired result }
inserttypeconv_explicit(resnode,resultdef);
end;
result:=true;
exit;
end
{ ord/enum -> set }
else if (left.resultdef.typ in [orddef,enumdef]) then
begin
if not check_only then
begin
resnode:=to_set_explicit_typecast;
{ convert to desired result }
inserttypeconv_explicit(resnode,getpointerdef(resultdef));
resnode:=cderefnode.create(resnode);
end;
result:=true;
exit;
end;
{ if someone needs it, float->set and set->float explicit typecasts
could also be added (cannot be handled by the above, because
float(intvalue) will convert rather than re-interpret the value) }
end;
{$ifndef nounsupported}
{ non-literal type conversions }
if convtype in
[tc_char_2_string,
@ -858,7 +1030,6 @@ implementation
tc_real_2_real,
tc_proc_2_procvar,
tc_arrayconstructor_2_set,
tc_set_to_set,
tc_class_2_intf,
tc_array_2_dynarray] then
begin
@ -1027,7 +1198,14 @@ implementation
else if checkdef.typ=pointerdef then
checkdef:=tpointerdef(checkdef).pointeddef
else if checkdef.typ=enumdef then
checkdef:=tenumdef(checkdef).classdef;
checkdef:=tenumdef(checkdef).classdef
else if checkdef.typ=setdef then
begin
if tsetdef(checkdef).elementdef.typ=enumdef then
checkdef:=java_juenumset
else
checkdef:=java_jubitset;
end;
{$ifndef nounsupported}
if checkdef.typ=procvardef then
checkdef:=java_jlobject

View File

@ -26,8 +26,9 @@ unit njvmcon;
interface
uses
globtype,aasmbase,
symtype,
node,ncon,ncgcon;
node,ncal,ncon,ncgcon;
type
tjvmordconstnode = class(tcgordconstnode)
@ -49,14 +50,44 @@ interface
procedure pass_generate_code;override;
end;
tjvmsetconsttype = (
{ create symbol for the set constant; the symbol will be initialized
in the class constructor/unit init code (default) }
sct_constsymbol,
{ normally, we convert the set constant into a constructor/factory
method to create a set instance. In some cases (simple "in"
expressions, adding an element to an empty set, ...) we want to
keep the set constant instead }
sct_notransform,
{ actually construct a JUBitSet/JUEnumSet that contains the set value
(for initializing the sets contstants) }
sct_construct
);
tjvmsetconstnode = class(tcgsetconstnode)
setconsttype: tjvmsetconsttype;
function pass_1: tnode; override;
procedure pass_generate_code; override;
constructor create(s : pconstset;def:tdef);override;
function docompare(p: tnode): boolean; override;
function dogetcopy: tnode; override;
protected
function emitvarsetconst: tasmsymbol; override;
{ in case the set has only a single run of consecutive elements,
this function will return its starting index and length }
function find_single_elements_run(from: longint; out start, len: longint): boolean;
function buildbitset: tnode;
function buildenumset(const eledef: tdef): tnode;
function buildsetfromstring(const helpername: string; otherparas: tcallparanode): tnode;
end;
implementation
uses
globtype,cutils,widestr,verbose,constexp,
cutils,widestr,verbose,constexp,fmodule,
symdef,symsym,symtable,symconst,
aasmdata,aasmcpu,defutil,
ncal,nld,
ncnv,nld,nmem,pjvm,pass_1,
cgbase,hlcgobj,hlcgcpu,cgutils,cpubase
;
@ -203,9 +234,240 @@ implementation
end;
{*****************************************************************************
TJVMSETCONSTNODE
*****************************************************************************}
function tjvmsetconstnode.buildsetfromstring(const helpername: string; otherparas: tcallparanode): tnode;
var
pw: pcompilerwidestring;
wc: tcompilerwidechar;
i, j, bit, nulls: longint;
begin
initwidestring(pw);
nulls:=0;
for i:=0 to 15 do
begin
wc:=0;
for bit:=0 to 15 do
if (i*16+bit) in value_set^ then
wc:=wc or (1 shl (15-bit));
{ don't add trailing zeroes }
if wc=0 then
inc(nulls)
else
begin
for j:=1 to nulls do
concatwidestringchar(pw,0);
nulls:=0;
concatwidestringchar(pw,wc);
end;
end;
result:=ccallnode.createintern(helpername,
ccallparanode.create(cstringconstnode.createwstr(pw),otherparas));
donewidestring(pw);
end;
function tjvmsetconstnode.buildbitset: tnode;
var
mp: tnode;
begin
if value_set^=[] then
begin
mp:=cloadvmtaddrnode.create(ctypenode.create(java_jubitset));
result:=ccallnode.createinternmethod(mp,'CREATE',nil);
exit;
end;
result:=buildsetfromstring('fpc_bitset_from_string',nil);
end;
function tjvmsetconstnode.buildenumset(const eledef: tdef): tnode;
var
stopnode: tnode;
startnode: tnode;
mp: tnode;
len: longint;
start: longint;
enumele: tnode;
paras: tcallparanode;
hassinglerun: boolean;
begin
hassinglerun:=find_single_elements_run(0, start, len);
mp:=cloadvmtaddrnode.create(ctypenode.create(java_juenumset));
if hassinglerun then
begin
if len=0 then
begin
enumele:=cloadvmtaddrnode.create(ctypenode.create(tenumdef(eledef).getbasedef.classdef));
inserttypeconv_explicit(enumele,search_system_type('JLCLASS').typedef);
paras:=ccallparanode.create(enumele,nil);
result:=ccallnode.createinternmethod(mp,'NONEOF',paras)
end
else
begin
startnode:=cordconstnode.create(start,eledef,false);
{ immediately firstpass so the enum gets translated into a JLEnum
instance }
firstpass(startnode);
if len=1 then
result:=ccallnode.createinternmethod(mp,'OF',ccallparanode.create(startnode,nil))
else
begin
stopnode:=cordconstnode.create(start+len-1,eledef,false);
firstpass(stopnode);
result:=ccallnode.createinternmethod(mp,'RANGE',ccallparanode.create(stopnode,ccallparanode.create(startnode,nil)));
end
end
end
else
begin
enumele:=cordconstnode.create(tenumsym(tenumdef(eledef).symtable.symlist[0]).value,eledef,false);
firstpass(enumele);
paras:=ccallparanode.create(enumele,nil);
result:=buildsetfromstring('fpc_enumset_from_string',paras);
end;
end;
function tjvmsetconstnode.pass_1: tnode;
var
eledef: tdef;
begin
{ we want set constants to be global, so we can reuse them. However,
if the set's elementdef is local, we can't do that since a global
symbol cannot have a local definition (the compiler will crash when
loading the ppu file afterwards) }
if tsetdef(resultdef).elementdef.owner.symtabletype=localsymtable then
setconsttype:=sct_construct;
result:=nil;
case setconsttype of
sct_constsymbol:
begin
{ normally a codegen pass routine, but we have to insert a typed
const in case the set constant does not exist yet, and that
should happen in pass_1 (especially since it involves creating
new nodes, which may even have to be tacked on to this code in
case it's the unit initialization code) }
handlevarsetconst;
{ no smallsets }
expectloc:=LOC_CREFERENCE;
end;
sct_notransform:
begin
result:=inherited pass_1;
{ no smallsets }
expectloc:=LOC_CREFERENCE;
end;
sct_construct:
begin
eledef:=tsetdef(resultdef).elementdef;
{ empty sets don't have an element type, so we don't know whether we
have to constructor a bitset or enumset (and of which type) }
if not assigned(eledef) then
internalerror(2011070202);
if eledef.typ=enumdef then
begin
result:=buildenumset(eledef);
end
else
begin
result:=buildbitset;
end;
inserttypeconv_explicit(result,getpointerdef(resultdef));
result:=cderefnode.create(result);
end;
else
internalerror(2011060301);
end;
end;
procedure tjvmsetconstnode.pass_generate_code;
begin
case setconsttype of
sct_constsymbol:
begin
{ all sets are varsets for the JVM target, no setbase differences }
handlevarsetconst;
end;
else
{ must be handled in pass_1 or otherwise transformed }
internalerror(2011070201)
end;
end;
constructor tjvmsetconstnode.create(s: pconstset; def: tdef);
begin
inherited create(s, def);
setconsttype:=sct_constsymbol;
end;
function tjvmsetconstnode.docompare(p: tnode): boolean;
begin
result:=
inherited docompare(p) and
(setconsttype=tjvmsetconstnode(p).setconsttype);
end;
function tjvmsetconstnode.dogetcopy: tnode;
begin
result:=inherited dogetcopy;
tjvmsetconstnode(result).setconsttype:=setconsttype;
end;
function tjvmsetconstnode.emitvarsetconst: tasmsymbol;
var
csym: tconstsym;
ssym: tstaticvarsym;
ps: pnormalset;
begin
{ add a read-only typed constant }
new(ps);
ps^:=value_set^;
csym:=tconstsym.create_ptr('_$setconst'+tostr(current_module.symlist.count),constset,ps,resultdef);
csym.visibility:=vis_private;
include(csym.symoptions,sp_internal);
current_module.localsymtable.insert(csym);
{ generate assignment of the constant to the typed constant symbol }
ssym:=jvm_add_typed_const_initializer(csym);
result:=current_asmdata.RefAsmSymbol(ssym.mangledname);
end;
function tjvmsetconstnode.find_single_elements_run(from: longint; out start, len: longint): boolean;
var
i: longint;
begin
i:=from;
result:=true;
{ find first element in set }
while (i<=255) and
not(i in value_set^) do
inc(i);
start:=i;
{ go to end of the run }
while (i<=255) and
(i in value_set^) do
inc(i);
len:=i-start;
{ rest must be unset }
while (i<=255) and
not(i in value_set^) do
inc(i);
if i<>256 then
result:=false;
end;
begin
cordconstnode:=tjvmordconstnode;
crealconstnode:=tjvmrealconstnode;
cstringconstnode:=tjvmstringconstnode;
csetconstnode:=tjvmsetconstnode;
end.

View File

@ -60,6 +60,7 @@ interface
function first_round_real: tnode; override;
*)
function first_new: tnode; override;
function first_IncludeExclude: tnode; override;
function first_setlength: tnode; override;
function first_length: tnode; override;
@ -314,6 +315,38 @@ implementation
end;
function tjvminlinenode.first_IncludeExclude: tnode;
var
setpara: tnode;
valuepara: tcallparanode;
seteledef: tdef;
procname: string[6];
begin
setpara:=tcallparanode(left).left;
tcallparanode(left).left:=nil;
valuepara:=tcallparanode(tcallparanode(left).right);
tcallparanode(left).right:=nil;
seteledef:=tsetdef(setpara.resultdef).elementdef;
setpara:=caddrnode.create_internal(setpara);
include(setpara.flags,nf_typedaddr);
if seteledef.typ=enumdef then
begin
inserttypeconv_explicit(setpara,java_juenumset);
inserttypeconv_explicit(valuepara.left,tenumdef(seteledef).getbasedef.classdef);
end
else
begin
inserttypeconv_explicit(setpara,java_jubitset);
inserttypeconv_explicit(valuepara.left,s32inttype);
end;
if inlinenumber=in_include_x_y then
procname:='ADD'
else
procname:='REMOVE';
result:=ccallnode.createinternmethod(setpara,procname,valuepara);
end;
function tjvminlinenode.first_setlength_array: tnode;
var
assignmenttarget,

View File

@ -30,6 +30,10 @@ interface
node,nset,ncgset;
type
tjvminnode = class(tcginnode)
function pass_1: tnode; override;
end;
tjvmcasenode = class(tcgcasenode)
function pass_1: tnode; override;
end;
@ -40,7 +44,57 @@ implementation
uses
symconst,symdef,
pass_1,
ncnv;
ncal,ncnv,ncon,nmem,
njvmcon,
cgbase;
{*****************************************************************************
TJVMINNODE
*****************************************************************************}
function tjvminnode.pass_1: tnode;
var
setparts: Tsetparts;
numparts: byte;
use_small: boolean;
isenum: boolean;
begin
{ before calling "inherited pass_1", so that in case left is an enum
constant it's not yet translated into a class instance }
isenum:=left.resultdef.typ=enumdef;
{ if we can use jumps, don't transform the set constant and (if
applicable) the value to be tested }
if checkgenjumps(setparts,numparts,use_small) then
begin
if right.nodetype=setconstn then
tjvmsetconstnode(right).setconsttype:=sct_notransform;
if isenum and
(left.nodetype=ordconstn) then
tjvmordconstnode(left).enumconstok:=true;
end;
result:=inherited pass_1;
if assigned(result) then
exit;
{ in case of jumps let the regular code handle it }
if expectloc=LOC_JUMP then
exit;
{ otherwise call set helper }
right:=caddrnode.create_internal(right);
include(right.flags,nf_typedaddr);
if isenum then
begin
inserttypeconv_explicit(left,java_jlenum);
inserttypeconv_explicit(right,java_juenumset);
end
else
begin
inserttypeconv_explicit(left,s32inttype);
inserttypeconv_explicit(right,java_jubitset);
end;
result:=ccallnode.createinternmethod(right,'CONTAINS',ccallparanode.create(left,nil));
right:=nil;
left:=nil;
end;
{*****************************************************************************
@ -60,5 +114,6 @@ implementation
begin
cinnode:=tjvminnode;
ccasenode:=tjvmcasenode;
end.

57
compiler/jvm/njvmtcon.pas Normal file
View File

@ -0,0 +1,57 @@
{
Copyright (c) 2011 by Jonas Maebe
Generates nodes for typed constant declarations
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.
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. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
****************************************************************************
}
unit njvmtcon;
{$i fpcdefs.inc}
interface
uses
node,
symdef,
ngtcon;
type
tjvmtypedconstbuilder = class(tnodetreetypedconstbuilder)
protected
procedure tc_emit_setdef(def: tsetdef; var node: tnode);override;
end;
implementation
uses
njvmcon;
procedure tjvmtypedconstbuilder.tc_emit_setdef(def: tsetdef; var node: tnode);
begin
{ indicate that set constant nodes have to be transformed into
constructors here }
if node.nodetype=setconstn then
tjvmsetconstnode(node).setconsttype:=sct_construct;
inherited tc_emit_setdef(def,node);
end;
begin
ctypedconstbuilder:=tjvmtypedconstbuilder;
end.

View File

@ -124,12 +124,51 @@ unit tgcpu;
end;
setdef:
begin
if is_smallset(def) then
exit;
{$ifndef nounsupported}
if tsetdef(def).elementdef.typ=enumdef then
begin
{ load enum class type }
list.concat(taicpu.op_sym(a_ldc,current_asmdata.RefAsmSymbol(tenumdef(tsetdef(def).elementdef).getbasedef.classdef.jvm_full_typename(true))));
thlcgjvm(hlcg).incstack(current_asmdata.CurrAsmList,1);
{ call tenumset.noneOf() class method }
sym:=tsym(tobjectdef(java_juenumset).symtable.find('NONEOF'));
if assigned(sym) and
(sym.typ=procsym) then
begin
if tprocsym(sym).procdeflist.Count<>1 then
internalerror(2011062801);
pd:=tprocdef(tprocsym(sym).procdeflist[0]);
end;
hlcg.a_call_name(list,pd,pd.mangledname,false);
{ static calls method replaces parameter with set instance
-> no change in stack height }
end
else
begin
list.concat(taicpu.op_sym(a_new,current_asmdata.RefAsmSymbol(java_jubitset.jvm_full_typename(true))));
{ the constructor doesn't return anything, so put a duplicate of the
self pointer on the evaluation stack for use as function result
after the constructor has run }
list.concat(taicpu.op_none(a_dup));
thlcgjvm(hlcg).incstack(list,2);
{ call the constructor }
sym:=tsym(java_jubitset.symtable.find('CREATE'));
if assigned(sym) and
(sym.typ=procsym) then
begin
pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
if not assigned(pd) then
internalerror(2011062802);
end
else
internalerror(2011062803);
hlcg.a_call_name(list,pd,pd.mangledname,false);
{ duplicate self pointer is removed }
thlcgjvm(hlcg).decstack(list,1);
end;
{ store reference to instance }
gettemp(list,java_jlobject.size,java_jlobject.alignment,temptype,ref);
thlcgjvm(hlcg).a_load_stack_ref(list,java_jlobject,ref,0);
result:=true;
{$endif}
end;
stringdef:
begin

View File

@ -93,7 +93,8 @@ implementation
begin
result:=false;
case def.typ of
classrefdef :
classrefdef,
setdef:
begin
result:=true;
end;
@ -140,8 +141,14 @@ implementation
end;
setdef :
begin
{ maybe one day }
internalerror(2011051404);
if tsetdef(def).elementdef.typ=enumdef then
begin
encodedstr:=encodedstr+'Ljava/util/EnumSet<';
jvmaddencodedtype(tenumdef(tsetdef(def).elementdef).getbasedef,false,encodedstr,true,founderror);
encodedstr:=encodedstr+'>;';
end
else
internalerror(2011051404);
end;
arraydef :
begin
@ -283,25 +290,20 @@ implementation
{ we can however annotate it with extra signature information in
using Java's generic annotations }
else
begin
encodedstr:=encodedstr+'Ljava/lang/Class<';
result:=jvmaddencodedtype(tclassrefdef(def).pointeddef,true,encodedstr,forcesignature,founderror);
encodedstr:=encodedstr+'>;';
end;
jvmaddencodedsignature(def,false,encodedstr);
result:=true;
end;
setdef :
begin
if is_smallset(def) then
encodedstr:=encodedstr+'I'
if tsetdef(def).elementdef.typ=enumdef then
begin
if forcesignature then
jvmaddencodedsignature(def,false,encodedstr)
else
result:=jvmaddencodedtype(java_juenumset,false,encodedstr,forcesignature,founderror)
end
else
{$ifndef nounsupported}
result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror);
{$else}
{ will be hanlded via wrapping later, although wrapping may
happen at higher level }
result:=false;
{$endif}
result:=jvmaddencodedtype(java_jubitset,false,encodedstr,forcesignature,founderror)
end;
formaldef :
begin
@ -461,6 +463,13 @@ implementation
result:='R'
else if is_shortstring(def) then
result:='T'
else if def.typ=setdef then
begin
if tsetdef(def).elementdef.typ=enumdef then
result:='E'
else
result:='L'
end
else
begin
if not jvmtryencodetype(def,res,false,errdef) then
@ -481,12 +490,11 @@ implementation
is_open_array(def) or
is_array_of_const(def) or
is_array_constructor(def);
recorddef:
recorddef,
setdef:
result:=true;
objectdef:
result:=is_object(def);
setdef:
result:=not is_smallset(def);
stringdef :
result:=tstringdef(def).stringtype in [st_shortstring,st_longstring];
else

View File

@ -2112,12 +2112,6 @@ implementation
newstatement : tstatementnode;
temp : ttempcreatenode;
begin
{$ifdef jvm}
{$ifndef nounsupported}
result:=cnothingnode.create;
exit;
{$endif nounsupported}
{$endif}
result:=nil;
case nodetype of
equaln,unequaln,lten,gten:

View File

@ -27,6 +27,7 @@ unit ncgcon;
interface
uses
aasmbase,
node,ncon;
type
@ -51,6 +52,10 @@ interface
end;
tcgsetconstnode = class(tsetconstnode)
protected
function emitvarsetconst: tasmsymbol; virtual;
procedure handlevarsetconst;
public
procedure pass_generate_code;override;
end;
@ -68,7 +73,7 @@ implementation
uses
globtype,widestr,systems,
verbose,globals,cutils,
symconst,symdef,aasmbase,aasmtai,aasmdata,aasmcpu,defutil,
symconst,symdef,aasmtai,aasmdata,aasmcpu,defutil,
cpuinfo,cpubase,
cgbase,cgobj,cgutils,
ncgutil, cclasses,asmutils,tgobj
@ -372,11 +377,52 @@ implementation
TCGSETCONSTNODE
*****************************************************************************}
procedure tcgsetconstnode.pass_generate_code;
function tcgsetconstnode.emitvarsetconst: tasmsymbol;
type
setbytes=array[0..31] of byte;
Psetbytes=^setbytes;
setbytes=array[0..31] of byte;
Psetbytes=^setbytes;
var
lab: tasmlabel;
i: longint;
begin
current_asmdata.getdatalabel(lab);
result:=lab;
lab_set:=lab;
maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,result.name,const_align(8));
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lab));
if (source_info.endian=target_info.endian) then
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
else
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
end;
procedure tcgsetconstnode.handlevarsetconst;
var
i : longint;
entry : PHashSetItem;
begin
location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8));
{ const already used ? }
if not assigned(lab_set) then
begin
if current_asmdata.ConstPools[sp_varsets] = nil then
current_asmdata.ConstPools[sp_varsets] := THashSet.Create(64, True, False);
entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
{ :-(, we must generate a new entry }
if not assigned(entry^.Data) then
entry^.Data:=emitvarsetconst;
lab_set := TAsmSymbol(entry^.Data);
end;
location.reference.symbol:=lab_set;
end;
procedure tcgsetconstnode.pass_generate_code;
procedure smallsetconst;
begin
@ -403,49 +449,6 @@ implementation
location.value:=location.value shr (32-resultdef.size*8);
end;
procedure varsetconst;
var
lastlabel : tasmlabel;
i : longint;
entry : PHashSetItem;
begin
{$ifdef jvm}
{$ifndef nounsupported}
location_reset_ref(location,LOC_REFERENCE,OS_ADDR,1);
tg.gethltemp(current_asmdata.CurrAsmList,resultdef,resultdef.size,tt_persistent,location.reference);
exit;
{$endif nounsupported}
{$endif jvm}
location_reset_ref(location,LOC_CREFERENCE,OS_NO,const_align(8));
lastlabel:=nil;
{ const already used ? }
if not assigned(lab_set) then
begin
if current_asmdata.ConstPools[sp_varsets] = nil then
current_asmdata.ConstPools[sp_varsets] := THashSet.Create(64, True, False);
entry := current_asmdata.ConstPools[sp_varsets].FindOrAdd(value_set, 32);
lab_set := TAsmLabel(entry^.Data); // is it needed anymore?
{ :-(, we must generate a new entry }
if not assigned(entry^.Data) then
begin
current_asmdata.getdatalabel(lastlabel);
lab_set:=lastlabel;
entry^.Data:=lastlabel;
maybe_new_object_file(current_asmdata.asmlists[al_typedconsts]);
new_section(current_asmdata.asmlists[al_typedconsts],sec_rodata_norel,lastlabel.name,const_align(8));
current_asmdata.asmlists[al_typedconsts].concat(Tai_label.Create(lastlabel));
if (source_info.endian=target_info.endian) then
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(Psetbytes(value_set)^[i]))
else
for i:=0 to 31 do
current_asmdata.asmlists[al_typedconsts].concat(Tai_const.Create_8bit(reverse_byte(Psetbytes(value_set)^[i])));
end;
end;
location.reference.symbol:=lab_set;
end;
begin
adjustforsetbase;
@ -454,7 +457,7 @@ implementation
if is_smallset(resultdef) then
smallsetconst
else
varsetconst;
handlevarsetconst;
end;

View File

@ -215,8 +215,11 @@ implementation
pleftreg : tregister;
setparts : Tsetparts;
opsize : tcgsize;
opdef : tdef;
uopsize : tcgsize;
uopdef : tdef;
orgopsize : tcgsize;
orgopdef : tdef;
genjumps,
use_small,
isjump : boolean;
@ -228,12 +231,21 @@ implementation
genjumps := checkgenjumps(setparts,numparts,use_small);
orgopsize := def_cgsize(left.resultdef);
orgopdef := left.resultdef;
uopsize := OS_32;
uopdef := u32inttype;
if is_signed(left.resultdef) then
opsize := tcgsize(ord(uopsize)+(ord(OS_S8)-ord(OS_8)))
begin
opsize := OS_S32;
opdef := s32inttype;
end
else
opsize := uopsize;
begin
opsize := uopsize;
opdef := uopdef;
end;
needslabel := false;
isjump:=false;
@ -259,7 +271,8 @@ implementation
secondpass(left);
if isjump then
begin
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,true);
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,orgopdef,opdef,true);
left.resultdef:=opdef;
current_procinfo.CurrTrueLabel:=otl;
current_procinfo.CurrFalseLabel:=ofl;
end
@ -276,17 +289,6 @@ implementation
if nf_swapped in flags then
swapleftright;
{$if defined(jvm) and not defined(nounsupported)}
if not is_smallset(left.resultdef) then
begin
location_reset(location, LOC_REGISTER, uopsize{def_cgsize(resultdef)});
{ allocate a register for the result }
location.register:=cg.getintregister(current_asmdata.CurrAsmList, uopsize);
hlcg.a_load_const_reg(current_asmdata.CurrAsmList,s32inttype,0,location.register);
exit;
end;
{$endif}
setbase:=tsetdef(right.resultdef).setbase;
if genjumps then
begin
@ -294,7 +296,7 @@ implementation
location_reset(location,LOC_JUMP,OS_NO);
{ If register is used, use only lower 8 bits }
location_force_reg(current_asmdata.CurrAsmList,left.location,opsize,false);
hlcg.location_force_reg(current_asmdata.CurrAsmList,left.location,left.resultdef,opdef,false);
pleftreg := left.location.register;
{ how much have we already substracted from the x in the }
@ -319,15 +321,15 @@ implementation
(hr<>pleftreg) then
begin
{ don't change this back to a_op_const_reg/a_load_reg_reg, since pleftreg must not be modified }
hr:=cg.getintregister(current_asmdata.CurrAsmList,opsize);
cg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,opsize,setparts[i].start,pleftreg,hr);
hr:=hlcg.getintregister(current_asmdata.CurrAsmList,opdef);
hlcg.a_op_const_reg_reg(current_asmdata.CurrAsmList,OP_SUB,opdef,setparts[i].start,pleftreg,hr);
pleftreg:=hr;
end
else
begin
{ otherwise, the value is already in a register }
{ that can be modified }
cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opsize,
hlcg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SUB,opdef,
setparts[i].start-adjustment,pleftreg)
end;
{ new total value substracted from x: }
@ -338,25 +340,25 @@ implementation
{ we need a carry in case the element is in the range }
{ (this will never overflow since we check at the }
{ beginning whether stop-start <> 255) }
cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_B,
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opdef, OC_B,
setparts[i].stop-setparts[i].start+1,pleftreg,current_procinfo.CurrTrueLabel);
end
else
{ if setparts[i].start = 0 and setparts[i].stop = 255, }
{ it's always true since "in" is only allowed for bytes }
begin
cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrTrueLabel);
end;
end
else
begin
{ Emit code to check if left is an element }
cg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opsize, OC_EQ,
hlcg.a_cmp_const_reg_label(current_asmdata.CurrAsmList, opdef, OC_EQ,
setparts[i].stop-adjustment,pleftreg,current_procinfo.CurrTrueLabel);
end;
{ To compensate for not doing a second pass }
right.location.reference.symbol:=nil;
cg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
hlcg.a_jmp_always(current_asmdata.CurrAsmList,current_procinfo.CurrFalseLabel);
end
else
{*****************************************************************}

View File

@ -144,7 +144,7 @@ interface
typedef : tdef;
typedefderef : tderef;
value_set : pconstset;
lab_set : tasmlabel;
lab_set : tasmsymbol;
constructor create(s : pconstset;def:tdef);virtual;
destructor destroy;override;
constructor ppuload(t:tnodetype;ppufile:tcompilerppufile);override;

View File

@ -476,11 +476,11 @@ implementation
make_not_regable(left,[ra_addr_regable,ra_addr_taken]);
{ don't allow constants, for internal use we also
allow taking the address of strings }
allow taking the address of strings and sets }
if is_constnode(left) and
not(
(nf_internal in flags) and
(left.nodetype in [stringconstn])
(left.nodetype in [stringconstn,setconstn])
) then
begin
CGMessagePos(left.fileinfo,type_e_no_addr_of_constant);

View File

@ -212,7 +212,7 @@ implementation
initialized at run time (enums, sets) -> create fake
typed const to do so }
if assigned(tconstsym(sym).constdef) and
(tconstsym(sym).constdef.typ=enumdef) then
(tconstsym(sym).constdef.typ in [enumdef,setdef]) then
jvm_add_typed_const_initializer(tconstsym(sym));
{$endif}
end

View File

@ -1303,6 +1303,10 @@ implementation
java_shortstring:=current_objectdef
else if (current_objectdef.objname^='JLENUM') then
java_jlenum:=current_objectdef
else if (current_objectdef.objname^='JUENUMSET') then
java_juenumset:=current_objectdef
else if (current_objectdef.objname^='FPCBITSET') then
java_jubitset:=current_objectdef
end;
end;
end;

View File

@ -41,7 +41,7 @@ interface
procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
procedure jvm_add_typed_const_initializer(csym: tconstsym);
function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
@ -53,7 +53,7 @@ implementation
verbose,systems,
fmodule,
parabase,aasmdata,
pdecsub,
pdecsub,ngenutil,
symtable,symcreat,defcmp,jvmdef,
defutil,paramgr;
@ -346,6 +346,22 @@ implementation
internalerror(2011062302);
include(pd.procoptions,po_staticmethod);
pd.synthetickind:=tsk_jvm_enum_valueof;
{ add instance method to convert an ordinal and an array into a set of
(we always need/can use both in case of subrange types and/or array
-> set type casts) }
if not str_parse_method_dec('function fpcLongToEnumSet(__val: jlong; __setbase, __setsize: jint): JUEnumSet;',potype_function,true,enumclass,pd) then
internalerror(2011070501);
pd.synthetickind:=tsk_jvm_enum_long2set;
if not str_parse_method_dec('function fpcBitSetToEnumSet(const __val: FpcBitSet; __fromsetbase, __tosetbase: jint): JUEnumSet; static;',potype_function,true,enumclass,pd) then
internalerror(2011071004);
pd.synthetickind:=tsk_jvm_enum_bitset2set;
if not str_parse_method_dec('function fpcEnumSetToEnumSet(const __val: JUEnumSet; __fromsetbase, __tosetbase: jint): JUEnumSet; static;',potype_function,true,enumclass,pd) then
internalerror(2011071005);
pd.synthetickind:=tsk_jvm_enum_set2set;
{ create array called "$VALUES" that will contain a reference to all
enum instances (JDK convention)
Disable duplicate identifier checking when inserting, because it will
@ -381,12 +397,16 @@ implementation
end;
procedure jvm_add_typed_const_initializer(csym: tconstsym);
function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
var
ssym: tstaticvarsym;
esym: tenumsym;
i: longint;
sstate: tscannerstate;
elemdef: tdef;
elemdefname,
conststr: ansistring;
first: boolean;
begin
case csym.constdef.typ of
enumdef:
@ -414,7 +434,58 @@ implementation
end;
str_parse_typedconst(current_asmdata.asmlists[al_typedconsts],esym.name+';',ssym);
restore_scanner(sstate);
end
result:=ssym;
end;
setdef:
begin
replace_scanner('jvm_set_const',sstate);
{ make sure we don't emit a definition for this field (we'll do
that for the constsym already) -> mark as external;
on the other hand, we don't create instances for constsyms in
(or external syms) the program/unit initialization code -> add
vo_has_local_copy to indicate that this should be done after all
(in thlcgjvm.allocate_implicit_structs_for_st_with_base_ref) }
{ the constant can be defined in the body of a function and its
def can also belong to that -> will be freed when the function
has been compiler -> insert a copy in the unit's staticsymtable
}
symtablestack.push(current_module.localsymtable);
ssym:=tstaticvarsym.create(internal_static_field_name(csym.realname),vs_final,tsetdef(csym.constdef).getcopy,[vo_is_external,vo_has_local_copy]);
symtablestack.top.insert(ssym);
symtablestack.pop(current_module.localsymtable);
{ alias storage to the constsym }
ssym.set_mangledname(csym.realname);
{ ensure that we allocate space for global symbols (won't actually
allocate space for this one, since it's external, but for the
constsym) }
cnodeutils.insertbssdata(ssym);
elemdef:=tsetdef(csym.constdef).elementdef;
if not assigned(elemdef) then
begin
internalerror(2011070502);
end
else
begin
elemdefname:=elemdef.typename;
conststr:='[';
first:=true;
for i:=0 to 255 do
if i in pnormalset(csym.value.valueptr)^ then
begin
if not first then
conststr:=conststr+',';
first:=false;
{ instead of looking up all enum value names/boolean
names, type cast integers to the required type }
conststr:=conststr+elemdefname+'('+tostr(i)+')';
end;
conststr:=conststr+'];';
end;
str_parse_typedconst(current_asmdata.asmlists[al_typedconsts],conststr,ssym);
restore_scanner(sstate);
result:=ssym;
end;
else
internalerror(2011062701);
end;

View File

@ -537,6 +537,66 @@ implementation
end;
procedure implement_jvm_enum_long2set(pd: tprocdef);
begin
str_parse_method_impl(
'var '+
'i, setval: jint;'+
'begin '+
'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+
'if __val<>0 then '+
'begin '+
'__setsize:=__setsize*8;'+
'for i:=0 to __setsize-1 do '+
// setsize-i because JVM = big endian
'if (__val and (jlong(1) shl (__setsize-i)))<>0 then '+
'result.add(fpcValueOf(i+__setbase));'+
'end '+
'end;',
pd,true);
end;
procedure implement_jvm_enum_bitset2set(pd: tprocdef);
begin
str_parse_method_impl(
'var '+
'i, setval: jint;'+
'begin '+
'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+
'i:=__val.nextSetBit(0);'+
'while i>=0 do '+
'begin '+
'setval:=-__fromsetbase;'+
'result.add(fpcValueOf(setval+__tosetbase));'+
'i:=__val.nextSetBit(i+1);'+
'end '+
'end;',
pd,true);
end;
procedure implement_jvm_enum_set2set(pd: tprocdef);
begin
str_parse_method_impl(
'var '+
'it: JUIterator;'+
'ele: FpcEnumValueObtainable;'+
'i: longint;'+
'begin '+
'result:=JUEnumSet.noneOf(JLClass(__FPC_TEnumClassAlias));'+
'it:=__val.iterator;'+
'while it.hasNext do '+
'begin '+
'ele:=FpcEnumValueObtainable(it.next);'+
'i:=ele.fpcOrdinal-__fromsetbase;'+
'result.add(fpcValueOf(i+__tosetbase));'+
'end '+
'end;',
pd,true);
end;
procedure add_synthetic_method_implementations_for_struct(struct: tabstractrecorddef);
var
i : longint;
@ -576,6 +636,12 @@ implementation
implement_jvm_enum_fpcordinal(pd);
tsk_jvm_enum_fpcvalueof:
implement_jvm_enum_fpcvalueof(pd);
tsk_jvm_enum_long2set:
implement_jvm_enum_long2set(pd);
tsk_jvm_enum_bitset2set:
implement_jvm_enum_bitset2set(pd);
tsk_jvm_enum_set2set:
implement_jvm_enum_set2set(pd);
else
internalerror(2011032801);
end;

View File

@ -507,7 +507,10 @@ interface
tsk_jvm_enum_classconstr, // Java class constructor for JLEnum descendants
tsk_jvm_enum_jumps_constr, // Java constructor for JLEnum descendants for enums with jumps
tsk_jvm_enum_fpcordinal, // Java FPCOrdinal function that returns the enum's ordinal value from an FPC POV
tsk_jvm_enum_fpcvalueof // Java FPCValueOf function that returns the enum instance corresponding to an ordinal from an FPC POV
tsk_jvm_enum_fpcvalueof, // Java FPCValueOf function that returns the enum instance corresponding to an ordinal from an FPC POV
tsk_jvm_enum_long2set, // Java fpcLongToEnumSet function that returns an enumset corresponding to a bit pattern in a jlong
tsk_jvm_enum_bitset2set, // Java fpcBitSetToEnumSet function that returns an enumset corresponding to a BitSet
tsk_jvm_enum_set2Set // Java fpcEnumSetToEnumSet function that returns an enumset corresponding to another enumset (different enum kind)
);
{$ifdef oldregvars}
@ -841,6 +844,10 @@ interface
java_jlstring : tobjectdef;
{ java.lang.Enum }
java_jlenum : tobjectdef;
{ java.util.EnumSet }
java_juenumset : tobjectdef;
{ java.util.BitSet }
java_jubitset : tobjectdef;
{ FPC java implementation of ansistrings }
java_ansistring : tobjectdef;
{ FPC java implementation of shortstrings }
@ -5004,6 +5011,10 @@ implementation
java_shortstring:=self
else if (objname^='JLENUM') then
java_jlenum:=self
else if (objname^='JUENUMSET') then
java_juenumset:=self
else if (objname^='FPCBITSET') then
java_jubitset:=self
end;
writing_class_record_dbginfo:=false;
end;

View File

@ -627,8 +627,29 @@ procedure fpc_initialize_array_unicodestring(arr: TJObjectArray; normalarrdim: l
level elements types of the array) }
procedure fpc_initialize_array_dynarr(arr: TJObjectArray; normalarrdim: longint);compilerproc;
procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint; inst: FpcBaseRecordType);compilerproc;
procedure fpc_initialize_array_bitset(arr: TJObjectArray; normalarrdim: longint; inst: FpcBitSet);compilerproc;
procedure fpc_initialize_array_enumset(arr: TJObjectArray; normalarrdim: longint; inst: JUEnumSet);compilerproc;
procedure fpc_initialize_array_shortstring(arr: TJObjectArray; normalarrdim: longint; maxlen: byte);compilerproc;
{ set helpers }
procedure fpc_bitset_copy(const src: FpcBitSet; dst: FpcBitSet); compilerproc;
procedure fpc_enumset_copy(const src: JUEnumSet; dst: JUEnumSet); compilerproc;
function fpc_enumset_symdif(const set1, set2: JUEnumSet): JUEnumSet; compilerproc;
function fpc_bitset_from_string(const s: unicodestring): FpcBitSet; compilerproc;
function fpc_enumset_from_string(dummy: FpcEnumValueObtainable; const s: unicodestring): JUEnumSet; compilerproc;
function fpc_enumset_to_int(const s: JUEnumSet; setbase, setsize: longint): jint; compilerproc;
function fpc_enumset_to_long(const s: JUEnumSet; setbase, setsize: longint): jlong; compilerproc;
function fpc_bitset_to_int(const s: FpcBitSet; setbase, setsize: longint): jint; compilerproc;
function fpc_bitset_to_long(const s: FpcBitSet; setbase, setsize: longint): jlong; compilerproc;
function fpc_int_to_bitset(const val: jint; setbase, setsize: jint): FpcBitSet; compilerproc;
function fpc_long_to_bitset(const val: jint; setbase, setsize: jint): FpcBitSet; compilerproc;
function fpc_enumset_to_bitset(const val: JUEnumSet; fromsetbase, tosetbase: jint): FpcBitSet; compilerproc;
function fpc_bitset_to_bitset(const s: FpcBitSet; fromsetbase, tosetbase: jint): FpcBitSet; compilerproc;
(*
{$ifdef FPC_SETBASE_USED}
procedure fpc_varset_load(const l;sourcesize : longint;var dest;size,srcminusdstbase : ptrint); compilerproc;

View File

@ -347,6 +347,12 @@
function equals(para1: JLObject): jboolean; overload;
end;
JUIterator = interface external 'java.util' name 'Iterator'
function hasNext(): jboolean; overload;
function next(): JLObject; overload;
procedure remove(); overload;
end;
JUMap = interface external 'java.util' name 'Map'
type
InnerEntry = interface;

View File

@ -1,4 +1,4 @@
{ Imports for Java packages/classes: java.io.Serializable, java.lang.AbstractStringBuilder, java.lang.Appendable, java.lang.Boolean, java.lang.Byte, java.lang.CharSequence, java.lang.Character, java.lang.Class, java.lang.Cloneable, java.lang.Comparable, java.lang.Double, java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, java.lang.IllegalArgumentException, java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, java.lang.LinkageError, java.lang.Long, java.lang.Number, java.lang.Object, java.lang.RuntimeException, java.lang.Short, java.lang.String, java.lang.StringBuffer, java.lang.StringBuilder, java.lang.System, java.lang.Throwable, java.lang.reflect.AnnotatedElement, java.lang.reflect.Array, java.lang.reflect.GenericDeclaration, java.lang.reflect.Type, java.text.Collator, java.util.AbstractCollection, java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, java.util.Collection, java.util.Comparator, java.util.EnumSet, java.util.HashMap, java.util.Map, java.util.Set }
{ Imports for Java packages/classes: java.io.Serializable, java.lang.AbstractStringBuilder, java.lang.Appendable, java.lang.Boolean, java.lang.Byte, java.lang.CharSequence, java.lang.Character, java.lang.Class, java.lang.Cloneable, java.lang.Comparable, java.lang.Double, java.lang.Enum, java.lang.Error, java.lang.Exception, java.lang.Float, java.lang.IllegalArgumentException, java.lang.IndexOutOfBoundsException, java.lang.Integer, java.lang.Iterable, java.lang.LinkageError, java.lang.Long, java.lang.Number, java.lang.Object, java.lang.RuntimeException, java.lang.Short, java.lang.String, java.lang.StringBuffer, java.lang.StringBuilder, java.lang.System, java.lang.Throwable, java.lang.reflect.AnnotatedElement, java.lang.reflect.Array, java.lang.reflect.GenericDeclaration, java.lang.reflect.Type, java.text.Collator, java.util.AbstractCollection, java.util.AbstractMap, java.util.AbstractSet, java.util.Arrays, java.util.BitSet, java.util.Collection, java.util.Comparator, java.util.EnumSet, java.util.HashMap, java.util.Iterator, java.util.Map, java.util.Set }
type
JLStringBuffer = class;
Arr1JLStringBuffer = array of JLStringBuffer;
@ -170,6 +170,11 @@ type
Arr2JLIterable = array of Arr1JLIterable;
Arr3JLIterable = array of Arr2JLIterable;
JUIterator = interface;
Arr1JUIterator = array of JUIterator;
Arr2JUIterator = array of Arr1JUIterator;
Arr3JUIterator = array of Arr2JUIterator;
JLCloneable = interface;
Arr1JLCloneable = array of JLCloneable;
Arr2JLCloneable = array of Arr1JLCloneable;
@ -325,11 +330,6 @@ type
Arr2JLAAnnotation = array of Arr1JLAAnnotation;
Arr3JLAAnnotation = array of Arr2JLAAnnotation;
JUIterator = interface external 'java.util' name 'Iterator';
Arr1JUIterator = array of JUIterator;
Arr2JUIterator = array of Arr1JUIterator;
Arr3JUIterator = array of Arr2JUIterator;
JNCChannel = interface external 'java.nio.channels' name 'Channel';
Arr1JNCChannel = array of JNCChannel;
Arr2JNCChannel = array of Arr1JNCChannel;

View File

@ -4630,12 +4630,6 @@
ALTERNATE = 4;
end;
JUIterator = interface external 'java.util' name 'Iterator'
function hasNext(): jboolean; overload;
function next(): JLObject; overload;
procedure remove(); overload;
end;
JULocaleISOData = class external 'java.util' name 'LocaleISOData' (JLObject)
end;
@ -23380,6 +23374,104 @@
function peek(): JLObject; overload;
end;
JUListIterator = interface external 'java.util' name 'ListIterator' (JUIterator)
function hasNext(): jboolean; overload;
function next(): JLObject; overload;
function hasPrevious(): jboolean; overload;
function previous(): JLObject; overload;
function nextIndex(): jint; overload;
function previousIndex(): jint; overload;
procedure remove(); overload;
procedure &set(para1: JLObject); overload;
procedure add(para1: JLObject); overload;
end;
JUScanner = class sealed external 'java.util' name 'Scanner' (JLObject, JUIterator)
public
constructor create(para1: JLReadable); overload;
constructor create(para1: JIInputStream); overload;
constructor create(para1: JIInputStream; para2: JLString); overload;
constructor create(para1: JIFile); overload; // throws java.io.FileNotFoundException
constructor create(para1: JIFile; para2: JLString); overload; // throws java.io.FileNotFoundException
constructor create(para1: JLString); overload;
constructor create(para1: JNCReadableByteChannel); overload;
constructor create(para1: JNCReadableByteChannel; para2: JLString); overload;
procedure close(); overload; virtual;
function ioException(): JIIOException; overload; virtual;
function delimiter(): JURPattern; overload; virtual;
function useDelimiter(para1: JURPattern): JUScanner; overload; virtual;
function useDelimiter(para1: JLString): JUScanner; overload; virtual;
function locale(): JULocale; overload; virtual;
function useLocale(para1: JULocale): JUScanner; overload; virtual;
function radix(): jint; overload; virtual;
function useRadix(para1: jint): JUScanner; overload; virtual;
function match(): JURMatchResult; overload; virtual;
function toString(): JLString; overload; virtual;
function hasNext(): jboolean; overload; virtual;
function next(): JLString; overload; virtual;
procedure remove(); overload; virtual;
function hasNext(para1: JLString): jboolean; overload; virtual;
function next(para1: JLString): JLString; overload; virtual;
function hasNext(para1: JURPattern): jboolean; overload; virtual;
function next(para1: JURPattern): JLString; overload; virtual;
function hasNextLine(): jboolean; overload; virtual;
function nextLine(): JLString; overload; virtual;
function findInLine(para1: JLString): JLString; overload; virtual;
function findInLine(para1: JURPattern): JLString; overload; virtual;
function findWithinHorizon(para1: JLString; para2: jint): JLString; overload; virtual;
function findWithinHorizon(para1: JURPattern; para2: jint): JLString; overload; virtual;
function skip(para1: JURPattern): JUScanner; overload; virtual;
function skip(para1: JLString): JUScanner; overload; virtual;
function hasNextBoolean(): jboolean; overload; virtual;
function nextBoolean(): jboolean; overload; virtual;
function hasNextByte(): jboolean; overload; virtual;
function hasNextByte(para1: jint): jboolean; overload; virtual;
function nextByte(): jbyte; overload; virtual;
function nextByte(para1: jint): jbyte; overload; virtual;
function hasNextShort(): jboolean; overload; virtual;
function hasNextShort(para1: jint): jboolean; overload; virtual;
function nextShort(): jshort; overload; virtual;
function nextShort(para1: jint): jshort; overload; virtual;
function hasNextInt(): jboolean; overload; virtual;
function hasNextInt(para1: jint): jboolean; overload; virtual;
function nextInt(): jint; overload; virtual;
function nextInt(para1: jint): jint; overload; virtual;
function hasNextLong(): jboolean; overload; virtual;
function hasNextLong(para1: jint): jboolean; overload; virtual;
function nextLong(): jlong; overload; virtual;
function nextLong(para1: jint): jlong; overload; virtual;
function hasNextFloat(): jboolean; overload; virtual;
function nextFloat(): jfloat; overload; virtual;
function hasNextDouble(): jboolean; overload; virtual;
function nextDouble(): jdouble; overload; virtual;
function hasNextBigInteger(): jboolean; overload; virtual;
function hasNextBigInteger(para1: jint): jboolean; overload; virtual;
function nextBigInteger(): JMBigInteger; overload; virtual;
function nextBigInteger(para1: jint): JMBigInteger; overload; virtual;
function hasNextBigDecimal(): jboolean; overload; virtual;
function nextBigDecimal(): JMBigDecimal; overload; virtual;
function reset(): JUScanner; overload; virtual;
function next(): JLObject; overload; virtual;
end;
JISPartialOrderIterator = class external 'javax.imageio.spi' name 'PartialOrderIterator' (JLObject, JUIterator)
public
constructor create(para1: JUIterator); overload;
function hasNext(): jboolean; overload; virtual;
function next(): JLObject; overload; virtual;
procedure remove(); overload; virtual;
end;
JXSXMLEventReader = interface external 'javax.xml.stream' name 'XMLEventReader' (JUIterator)
function nextEvent(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function hasNext(): jboolean; overload;
function peek(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function getElementText(): JLString; overload; // throws javax.xml.stream.XMLStreamException
function nextTag(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function getProperty(para1: JLString): JLObject; overload; // throws java.lang.IllegalArgumentException
procedure close(); overload; // throws javax.xml.stream.XMLStreamException
end;
JIFile = class external 'java.io' name 'File' (JLObject, JISerializable, JLComparable)
public
type
@ -31686,104 +31778,6 @@
procedure undoableEditHappened(para1: JSEUndoableEditEvent); overload;
end;
JUListIterator = interface external 'java.util' name 'ListIterator' (JUIterator)
function hasNext(): jboolean; overload;
function next(): JLObject; overload;
function hasPrevious(): jboolean; overload;
function previous(): JLObject; overload;
function nextIndex(): jint; overload;
function previousIndex(): jint; overload;
procedure remove(); overload;
procedure &set(para1: JLObject); overload;
procedure add(para1: JLObject); overload;
end;
JUScanner = class sealed external 'java.util' name 'Scanner' (JLObject, JUIterator)
public
constructor create(para1: JLReadable); overload;
constructor create(para1: JIInputStream); overload;
constructor create(para1: JIInputStream; para2: JLString); overload;
constructor create(para1: JIFile); overload; // throws java.io.FileNotFoundException
constructor create(para1: JIFile; para2: JLString); overload; // throws java.io.FileNotFoundException
constructor create(para1: JLString); overload;
constructor create(para1: JNCReadableByteChannel); overload;
constructor create(para1: JNCReadableByteChannel; para2: JLString); overload;
procedure close(); overload; virtual;
function ioException(): JIIOException; overload; virtual;
function delimiter(): JURPattern; overload; virtual;
function useDelimiter(para1: JURPattern): JUScanner; overload; virtual;
function useDelimiter(para1: JLString): JUScanner; overload; virtual;
function locale(): JULocale; overload; virtual;
function useLocale(para1: JULocale): JUScanner; overload; virtual;
function radix(): jint; overload; virtual;
function useRadix(para1: jint): JUScanner; overload; virtual;
function match(): JURMatchResult; overload; virtual;
function toString(): JLString; overload; virtual;
function hasNext(): jboolean; overload; virtual;
function next(): JLString; overload; virtual;
procedure remove(); overload; virtual;
function hasNext(para1: JLString): jboolean; overload; virtual;
function next(para1: JLString): JLString; overload; virtual;
function hasNext(para1: JURPattern): jboolean; overload; virtual;
function next(para1: JURPattern): JLString; overload; virtual;
function hasNextLine(): jboolean; overload; virtual;
function nextLine(): JLString; overload; virtual;
function findInLine(para1: JLString): JLString; overload; virtual;
function findInLine(para1: JURPattern): JLString; overload; virtual;
function findWithinHorizon(para1: JLString; para2: jint): JLString; overload; virtual;
function findWithinHorizon(para1: JURPattern; para2: jint): JLString; overload; virtual;
function skip(para1: JURPattern): JUScanner; overload; virtual;
function skip(para1: JLString): JUScanner; overload; virtual;
function hasNextBoolean(): jboolean; overload; virtual;
function nextBoolean(): jboolean; overload; virtual;
function hasNextByte(): jboolean; overload; virtual;
function hasNextByte(para1: jint): jboolean; overload; virtual;
function nextByte(): jbyte; overload; virtual;
function nextByte(para1: jint): jbyte; overload; virtual;
function hasNextShort(): jboolean; overload; virtual;
function hasNextShort(para1: jint): jboolean; overload; virtual;
function nextShort(): jshort; overload; virtual;
function nextShort(para1: jint): jshort; overload; virtual;
function hasNextInt(): jboolean; overload; virtual;
function hasNextInt(para1: jint): jboolean; overload; virtual;
function nextInt(): jint; overload; virtual;
function nextInt(para1: jint): jint; overload; virtual;
function hasNextLong(): jboolean; overload; virtual;
function hasNextLong(para1: jint): jboolean; overload; virtual;
function nextLong(): jlong; overload; virtual;
function nextLong(para1: jint): jlong; overload; virtual;
function hasNextFloat(): jboolean; overload; virtual;
function nextFloat(): jfloat; overload; virtual;
function hasNextDouble(): jboolean; overload; virtual;
function nextDouble(): jdouble; overload; virtual;
function hasNextBigInteger(): jboolean; overload; virtual;
function hasNextBigInteger(para1: jint): jboolean; overload; virtual;
function nextBigInteger(): JMBigInteger; overload; virtual;
function nextBigInteger(para1: jint): JMBigInteger; overload; virtual;
function hasNextBigDecimal(): jboolean; overload; virtual;
function nextBigDecimal(): JMBigDecimal; overload; virtual;
function reset(): JUScanner; overload; virtual;
function next(): JLObject; overload; virtual;
end;
JISPartialOrderIterator = class external 'javax.imageio.spi' name 'PartialOrderIterator' (JLObject, JUIterator)
public
constructor create(para1: JUIterator); overload;
function hasNext(): jboolean; overload; virtual;
function next(): JLObject; overload; virtual;
procedure remove(); overload; virtual;
end;
JXSXMLEventReader = interface external 'javax.xml.stream' name 'XMLEventReader' (JUIterator)
function nextEvent(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function hasNext(): jboolean; overload;
function peek(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function getElementText(): JLString; overload; // throws javax.xml.stream.XMLStreamException
function nextTag(): JXSEXMLEvent; overload; // throws javax.xml.stream.XMLStreamException
function getProperty(para1: JLString): JLObject; overload; // throws java.lang.IllegalArgumentException
procedure close(); overload; // throws javax.xml.stream.XMLStreamException
end;
JUListResourceBundle = class abstract external 'java.util' name 'ListResourceBundle' (JUResourceBundle)
public
constructor create(); overload;
@ -43690,6 +43684,23 @@
function drainTo(para1: JUCollection; para2: jint): jint; overload;
end;
JXSUEventReaderDelegate = class external 'javax.xml.stream.util' name 'EventReaderDelegate' (JLObject, JXSXMLEventReader)
public
constructor create(); overload;
constructor create(para1: JXSXMLEventReader); overload;
procedure setParent(para1: JXSXMLEventReader); overload; virtual;
function getParent(): JXSXMLEventReader; overload; virtual;
function nextEvent(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
function next(): JLObject; overload; virtual;
function hasNext(): jboolean; overload; virtual;
function peek(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
procedure close(); overload; virtual; // throws javax.xml.stream.XMLStreamException
function getElementText(): JLString; overload; virtual; // throws javax.xml.stream.XMLStreamException
function nextTag(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
function getProperty(para1: JLString): JLObject; overload; virtual; // throws java.lang.IllegalArgumentException
procedure remove(); overload; virtual;
end;
JTRuleBasedCollationKey = class sealed external 'java.text' name 'RuleBasedCollationKey' (JTCollationKey)
public
function compareTo(para1: JTCollationKey): jint; overload; virtual;
@ -49566,23 +49577,6 @@
procedure recalcWidthCache(); overload; virtual;
end;
JXSUEventReaderDelegate = class external 'javax.xml.stream.util' name 'EventReaderDelegate' (JLObject, JXSXMLEventReader)
public
constructor create(); overload;
constructor create(para1: JXSXMLEventReader); overload;
procedure setParent(para1: JXSXMLEventReader); overload; virtual;
function getParent(): JXSXMLEventReader; overload; virtual;
function nextEvent(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
function next(): JLObject; overload; virtual;
function hasNext(): jboolean; overload; virtual;
function peek(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
procedure close(); overload; virtual; // throws javax.xml.stream.XMLStreamException
function getElementText(): JLString; overload; virtual; // throws javax.xml.stream.XMLStreamException
function nextTag(): JXSEXMLEvent; overload; virtual; // throws javax.xml.stream.XMLStreamException
function getProperty(para1: JLString): JLObject; overload; virtual; // throws java.lang.IllegalArgumentException
procedure remove(); overload; virtual;
end;
JAAccessibleResourceBundle = class external 'javax.accessibility' name 'AccessibleResourceBundle' (JUListResourceBundle)
public
constructor create(); overload;

View File

@ -6935,16 +6935,16 @@ type
Arr2JNByteBufferAsIntBufferRL = array of Arr1JNByteBufferAsIntBufferRL;
Arr3JNByteBufferAsIntBufferRL = array of Arr2JNByteBufferAsIntBufferRL;
JXVSchemaFactoryLoader = class;
Arr1JXVSchemaFactoryLoader = array of JXVSchemaFactoryLoader;
Arr2JXVSchemaFactoryLoader = array of Arr1JXVSchemaFactoryLoader;
Arr3JXVSchemaFactoryLoader = array of Arr2JXVSchemaFactoryLoader;
JTRuleBasedCollator = class;
Arr1JTRuleBasedCollator = array of JTRuleBasedCollator;
Arr2JTRuleBasedCollator = array of Arr1JTRuleBasedCollator;
Arr3JTRuleBasedCollator = array of Arr2JTRuleBasedCollator;
JXVSchemaFactoryLoader = class;
Arr1JXVSchemaFactoryLoader = array of JXVSchemaFactoryLoader;
Arr2JXVSchemaFactoryLoader = array of Arr1JXVSchemaFactoryLoader;
Arr3JXVSchemaFactoryLoader = array of Arr2JXVSchemaFactoryLoader;
JSPBBasicTextPaneUI = class;
Arr1JSPBBasicTextPaneUI = array of JSPBBasicTextPaneUI;
Arr2JSPBBasicTextPaneUI = array of Arr1JSPBBasicTextPaneUI;
@ -17775,16 +17775,16 @@ type
Arr2OWDDOMImplementation = array of Arr1OWDDOMImplementation;
Arr3OWDDOMImplementation = array of Arr2OWDDOMImplementation;
OOCUNSUPPORTED_POLICY = interface;
Arr1OOCUNSUPPORTED_POLICY = array of OOCUNSUPPORTED_POLICY;
Arr2OOCUNSUPPORTED_POLICY = array of Arr1OOCUNSUPPORTED_POLICY;
Arr3OOCUNSUPPORTED_POLICY = array of Arr2OOCUNSUPPORTED_POLICY;
JTCharacterIterator = interface;
Arr1JTCharacterIterator = array of JTCharacterIterator;
Arr2JTCharacterIterator = array of Arr1JTCharacterIterator;
Arr3JTCharacterIterator = array of Arr2JTCharacterIterator;
OOCUNSUPPORTED_POLICY = interface;
Arr1OOCUNSUPPORTED_POLICY = array of OOCUNSUPPORTED_POLICY;
Arr2OOCUNSUPPORTED_POLICY = array of Arr1OOCUNSUPPORTED_POLICY;
Arr3OOCUNSUPPORTED_POLICY = array of Arr2OOCUNSUPPORTED_POLICY;
JXBAXmlSchemaType = interface;
Arr1JXBAXmlSchemaType = array of JXBAXmlSchemaType;
Arr2JXBAXmlSchemaType = array of Arr1JXBAXmlSchemaType;
@ -19665,11 +19665,6 @@ type
Arr2JNLExtendedResponse = array of Arr1JNLExtendedResponse;
Arr3JNLExtendedResponse = array of Arr2JNLExtendedResponse;
JUIterator = interface;
Arr1JUIterator = array of JUIterator;
Arr2JUIterator = array of Arr1JUIterator;
Arr3JUIterator = array of Arr2JUIterator;
JAEComponentListener = interface;
Arr1JAEComponentListener = array of JAEComponentListener;
Arr2JAEComponentListener = array of Arr1JAEComponentListener;
@ -20830,6 +20825,11 @@ type
Arr2JLCloneable = array of Arr1JLCloneable;
Arr3JLCloneable = array of Arr2JLCloneable;
JUIterator = interface external 'java.util' name 'Iterator';
Arr1JUIterator = array of JUIterator;
Arr2JUIterator = array of Arr1JUIterator;
Arr3JUIterator = array of Arr2JUIterator;
JUCollection = interface external 'java.util' name 'Collection';
Arr1JUCollection = array of JUCollection;
Arr2JUCollection = array of Arr1JUCollection;

View File

@ -25,6 +25,8 @@ type
TJDoubleArray = array of jdouble;
TJObjectArray = array of JLObject;
TJRecordArray = array of FpcBaseRecordType;
TJEnumSetArray = array of JUEnumSet;
TJBitSetArray = array of JUBitSet;
TShortstringArray = array of ShortstringClass;
TJStringArray = array of unicodestring;
@ -38,6 +40,8 @@ const
FPCJDynArrTypeJDouble = 'D';
FPCJDynArrTypeJObject = 'A';
FPCJDynArrTypeRecord = 'R';
FPCJDynArrTypeEnumSet = 'E';
FPCJDynArrTypeBitSet = 'L';
FPCJDynArrTypeShortstring = 'T';
{ 1-dimensional setlength routines
@ -54,6 +58,8 @@ function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepco
procedure fpc_copy_shallow_array(src, dst: JLObject; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1);
procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
{ multi-dimendional setlength routine: all intermediate dimensions are arrays

284
rtl/java/jset.inc Normal file
View File

@ -0,0 +1,284 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2011 by Jonas Maebe,
members of the Free Pascal development team.
This file implements support infrastructure for sets under the JVM
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
function FpcBitSet.add(elem: jint): FpcBitSet;
begin
&set(elem);
result:=self;
end;
function FpcBitSet.addAll(s: FpcBitSet): FpcBitSet;
begin
&or(s);
result:=self;
end;
function FpcBitSet.remove(elem: jint): FpcBitSet;
begin
clear(elem);
result:=self;
end;
function FpcBitSet.removeAll(s: FpcBitSet): FpcBitSet;
begin
andnot(s);
result:=self;
end;
function FpcBitSet.retainAll(s: FpcBitSet): FpcBitSet;
begin
&and(s);
result:=self;
end;
function FpcBitSet.contains(elem: jint): boolean;
begin
result:=get(elem);
end;
function FpcBitSet.containsAll(s: FpcBitSet): boolean;
var
tmp: FpcBitSet;
begin
tmp:=FpcBitSet(clone);
tmp.&and(s);
result:=tmp.equals(s);
end;
function FpcBitSet.symdif(s: FpcBitSet): FpcBitSet;
begin
s.&xor(s);
result:=self;
end;
class function FpcBitSet.range(start, stop: jint): FpcBitSet;
begin
result:=FpcBitSet.create(stop);
result.&set(start,stop+1);
end;
class function FpcBitSet.&of(elem: jint): FpcBitSet;
begin
result:=FpcBitSet.create(elem);
result.&set(elem);
end;
procedure fpc_bitset_copy(const src: FpcBitSet; dst: FpcBitSet); compilerproc;
begin
dst.clear();
dst.&or(src);
end;
procedure fpc_enumset_copy(const src: JUEnumSet; dst: JUEnumSet); compilerproc;
begin
dst.clear();
dst.addAll(src);
end;
function fpc_enumset_symdif(const set1, set2: JUEnumSet): JUEnumSet; compilerproc;
var
tmp: JUEnumSet;
begin
{ (set1 + set 2) - (set1 * set2) }
result:=JUEnumSet(set1.clone);
result.addAll(set2);
tmp:=JUEnumSet(set1.clone);
tmp.retainAll(set2);
result.removeAll(tmp);
end;
function fpc_bitset_from_string(const s: unicodestring): FpcBitSet; compilerproc;
var
i, bits: longint;
wc: word;
begin
{ all bits are encoded in the string characters }
result:=FpcBitSet.Create(cardinal(length(s)+15) div 16);
for i:=1 to length(s) do
begin
wc:=word(s[i]);
if wc=0 then
continue;
for bits:=15 downto 0 do
if (wc and (1 shl bits)) <> 0 then
result.&set((i-1)*16+15-bits);
end;
end;
function fpc_enumset_from_string(dummy: FpcEnumValueObtainable; const s: unicodestring): JUEnumSet; compilerproc;
var
i, bits: longint;
wc: word;
begin
{ all bits are encoded in the string characters }
result:=JUEnumSet.noneOf(JLObject(dummy).getClass);
for i:=1 to length(s) do
begin
wc:=word(s[i]);
if wc=0 then
continue;
for bits:=15 downto 0 do
if (wc and (1 shl bits)) <> 0 then
result.add(dummy.fpcGenericValueOf((i-1)*16+15-bits));
end;
end;
function fpc_enumset_to_int(const s: JUEnumSet; setbase, setsize: longint): jint; compilerproc;
var
it: JUIterator;
ele: FpcEnumValueObtainable;
val: longint;
begin
it:=s.iterator;
result:=0;
setsize:=setsize*8;
while it.hasNext do
begin
ele:=FpcEnumValueObtainable(it.next);
val:=ele.fpcOrdinal-setbase;
result:=result or (1 shl (setsize-val));
end;
end;
function fpc_enumset_to_long(const s: JUEnumSet; setbase, setsize: longint): jlong; compilerproc;
var
it: JUIterator;
ele: FpcEnumValueObtainable;
val: longint;
begin
it:=s.iterator;
result:=0;
setsize:=setsize*8;
while it.hasNext do
begin
ele:=FpcEnumValueObtainable(it.next);
val:=ele.fpcOrdinal-setbase;
result:=result or (1 shl (setsize-val));
end;
end;
function fpc_bitset_to_int(const s: FpcBitSet; setbase, setsize: longint): jint; compilerproc;
var
i, val: longint;
begin
result:=0;
setsize:=setsize*8;
i:=s.nextSetBit(0);
while i>=0 do
begin
val:=i-setbase;
result:=result or (1 shl (setsize-val));
i:=s.nextSetBit(i+1);
end;
end;
function fpc_bitset_to_long(const s: FpcBitSet; setbase, setsize: longint): jlong; compilerproc;
var
i, val: longint;
begin
result:=0;
setsize:=setsize*8;
i:=s.nextSetBit(0);
while i>=0 do
begin
val:=i-setbase;
result:=result or (1 shl (setsize-val));
i:=s.nextSetBit(i+1);
end;
end;
function fpc_int_to_bitset(const val: jint; setbase, setsize: jint): FpcBitSet; compilerproc;
var
i, setval: jint;
begin
result:=FpcBitSet.create;
if val<>0 then
begin
setsize:=setsize*8;
for i:=0 to setsize-1 do
if (val and (jint(1) shl (setsize-i)))<>0 then
result.&set(i+setbase);
end;
end;
function fpc_long_to_bitset(const val: jint; setbase, setsize: jint): FpcBitSet; compilerproc;
var
i, setval: jint;
begin
result:=FpcBitSet.create;
if val<>0 then
begin
setsize:=setsize*8;
for i:=0 to setsize-1 do
if (val and (jlong(1) shl (setsize-i)))<>0 then
result.&set(i+setbase);
end;
end;
function fpc_enumset_to_bitset(const val: JUEnumSet; fromsetbase, tosetbase: jint): FpcBitSet; compilerproc;
var
it: JUIterator;
ele: FpcEnumValueObtainable;
i: longint;
begin
result:=FpcBitSet.Create;
it:=val.iterator;
while it.hasNext do
begin
ele:=FpcEnumValueObtainable(it.next);
i:=ele.fpcOrdinal-fromsetbase;
result.&set(i+tosetbase);
end;
end;
function fpc_bitset_to_bitset(const s: FpcBitSet; fromsetbase, tosetbase: jint): FpcBitSet; compilerproc;
var
i, val: longint;
begin
result:=FpcBitSet.create;
i:=s.nextSetBit(0);
while i>=0 do
begin
val:=i-fromsetbase;
result.&set(val+tosetbase);
i:=s.nextSetBit(i+1);
end;
end;

33
rtl/java/jseth.inc Normal file
View File

@ -0,0 +1,33 @@
{
This file is part of the Free Pascal run time library.
Copyright (c) 2011 by Jonas Maebe,
members of the Free Pascal development team.
This file declares support infrastructure for sets under the JVM
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
type
{ Adds support for a "base" value that is used as lower bound for the set's
contents }
FpcBitSet = class sealed (JUBitSet)
function add(elem: jint): FpcBitSet;
function addAll(s: FpcBitSet): FpcBitSet;
function remove(elem: jint): FpcBitSet;
function removeAll(s: FpcBitSet): FpcBitSet;
function retainAll(s: FpcBitSet): FpcBitSet;
function contains(elem: jint): boolean;
function containsAll(s: FpcBitSet): boolean;
function symdif(s: FpcBitSet): FpcBitSet;
class function range(start, stop: jint): FpcBitSet; static;
class function &of(elem: jint): FpcBitSet; static;
end;

View File

@ -87,6 +87,48 @@ procedure fpc_initialize_array_record(arr: TJObjectArray; normalarrdim: longint;
end;
{ exactly the same as fpc_initialize_array_record, but can't use generic
routine because of Java clonable design :( (except by rtti/invoke, but that's
not particularly fast either) }
procedure fpc_initialize_array_bitset_intern(arr: TJObjectArray; normalarrdim: longint; inst: FpcBitSet); external name 'fpc_initialize_array_bitset';
procedure fpc_initialize_array_bitset(arr: TJObjectArray; normalarrdim: longint; inst: FpcBitSet);compilerproc;
var
i: longint;
begin
if normalarrdim > 0 then
begin
for i:=low(arr) to high(arr) do
fpc_initialize_array_bitset_intern(TJObjectArray(arr[i]),normalarrdim-1,inst);
end
else
begin
for i:=low(arr) to high(arr) do
arr[i]:=inst.clone;
end;
end;
{ idem }
procedure fpc_initialize_array_enumset_intern(arr: TJObjectArray; normalarrdim: longint; inst: JUEnumSet); external name 'fpc_initialize_array_enumset';
procedure fpc_initialize_array_enumset(arr: TJObjectArray; normalarrdim: longint; inst: JUEnumSet);compilerproc;
var
i: longint;
begin
if normalarrdim > 0 then
begin
for i:=low(arr) to high(arr) do
fpc_initialize_array_enumset_intern(TJObjectArray(arr[i]),normalarrdim-1,inst);
end
else
begin
for i:=low(arr) to high(arr) do
arr[i]:=inst.clone;
end;
end;
procedure fpc_initialize_array_shortstring_intern(arr: TJObjectArray; normalarrdim: longint; maxlen: byte); external name 'fpc_initialize_array_shortstring';
procedure fpc_initialize_array_shortstring(arr: TJObjectArray; normalarrdim: longint; maxlen: byte);compilerproc;

View File

@ -129,6 +129,7 @@ type
{$i innr.inc}
{$i jmathh.inc}
{$i jrech.inc}
{$i jseth.inc}
{$i sstringh.inc}
{$i jdynarrh.inc}
{$i astringh.inc}
@ -287,6 +288,7 @@ function min(a,b : longint) : longint;
{$i ustrings.inc}
{$i rtti.inc}
{$i jrec.inc}
{$i jset.inc}
{$i jint64.inc}
{ copying helpers }
@ -340,6 +342,48 @@ procedure fpc_copy_jrecord_array(src, dst: TJRecordArray; srcstart: jint = -1; s
end;
procedure fpc_copy_jenumset_array(src, dst: TJEnumSetArray; srcstart: jint = -1; srccopylen: jint = -1);
var
i: longint;
srclen, dstlen: jint;
begin
srclen:=length(src);
dstlen:=length(dst);
if srcstart=-1 then
srcstart:=0
else if srcstart>=srclen then
exit;
if srccopylen=-1 then
srccopylen:=srclen
else if srcstart+srccopylen>srclen then
srccopylen:=srclen-srcstart;
{ no arraycopy, have to clone each element }
for i:=0 to min(srccopylen,dstlen)-1 do
dst[i]:=JUEnumSet(src[srcstart+i].clone);
end;
procedure fpc_copy_jbitset_array(src, dst: TJBitSetArray; srcstart: jint = -1; srccopylen: jint = -1);
var
i: longint;
srclen, dstlen: jint;
begin
srclen:=length(src);
dstlen:=length(dst);
if srcstart=-1 then
srcstart:=0
else if srcstart>=srclen then
exit;
if srccopylen=-1 then
srccopylen:=srclen
else if srcstart+srccopylen>srclen then
srccopylen:=srclen-srcstart;
{ no arraycopy, have to clone each element }
for i:=0 to min(srccopylen,dstlen)-1 do
dst[i]:=JUBitset(src[srcstart+i].clone);
end;
procedure fpc_copy_jshortstring_array(src, dst: TShortstringArray; srcstart: jint = -1; srccopylen: jint = -1);
var
i: longint;
@ -405,6 +449,33 @@ function fpc_setlength_dynarr_jrecord(aorg, anew: TJRecordArray; deepcopy: boole
end;
function fpc_setlength_dynarr_jenumset(aorg, anew: TJEnumSetArray; deepcopy: boolean): TJEnumSetArray;
begin
if deepcopy or
(length(aorg)<>length(anew)) then
begin
fpc_copy_jenumset_array(aorg,anew);
result:=anew
end
else
result:=aorg;
end;
function fpc_setlength_dynarr_jbitset(aorg, anew: TJBitSetArray; deepcopy: boolean): TJBitSetArray;
begin
if deepcopy or
(length(aorg)<>length(anew)) then
begin
fpc_copy_jbitset_array(aorg,anew);
result:=anew
end
else
result:=aorg;
end;
function fpc_setlength_dynarr_jshortstring(aorg, anew: TShortstringArray; deepcopy: boolean): TShortstringArray;
begin
if deepcopy or
@ -451,6 +522,20 @@ function fpc_setlength_dynarr_multidim(aorg, anew: TJObjectArray; deepcopy: bool
for i:=succ(partdone) to high(result) do
result[i]:=JLObject(fpc_setlength_dynarr_jrecord(nil,TJRecordArray(anew[i]),deepcopy));
end;
FPCJDynArrTypeEnumSet:
begin
for i:=low(result) to partdone do
result[i]:=JLObject(fpc_setlength_dynarr_jenumset(TJEnumSetArray(aorg[i]),TJEnumSetArray(anew[i]),deepcopy));
for i:=succ(partdone) to high(result) do
result[i]:=JLObject(fpc_setlength_dynarr_jenumset(nil,TJEnumSetArray(anew[i]),deepcopy));
end;
FPCJDynArrTypeBitSet:
begin
for i:=low(result) to partdone do
result[i]:=JLObject(fpc_setlength_dynarr_jbitset(TJBitSetArray(aorg[i]),TJBitSetArray(anew[i]),deepcopy));
for i:=succ(partdone) to high(result) do
result[i]:=JLObject(fpc_setlength_dynarr_jbitset(nil,TJBitSetArray(anew[i]),deepcopy));
end;
FPCJDynArrTypeShortstring:
begin
for i:=low(result) to partdone do