fpc/compiler/jvm/jvmdef.pas

1170 lines
41 KiB
ObjectPascal
Raw Permalink Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

{
Copyright (c) 2010 by Jonas Maebe
This unit implements some JVM type helper routines (minimal
unit dependencies, usable in symdef).
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.
****************************************************************************
}
{$i fpcdefs.inc}
unit jvmdef;
interface
uses
globtype,
node,
symbase,symtype,symdef;
{ returns whether a def can make use of an extra type signature (for
Java-style generics annotations; not use for FPC-style generics or their
translations, but to annotate the kind of classref a java.lang.Class is
and things like that) }
function jvmtypeneedssignature(def: tdef): boolean;
{ create a signature encoding of a particular type; requires that
jvmtypeneedssignature returned "true" for this type }
procedure jvmaddencodedsignature(def: tdef; bpacked: boolean; var encodedstr: TSymStr);
{ Encode a type into the internal format used by the JVM (descriptor).
Returns false if a type is not representable by the JVM,
and in that case also the failing definition. }
function jvmtryencodetype(def: tdef; out encodedtype: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
{ same as above, but throws an internal error on failure }
function jvmencodetype(def: tdef; withsignature: boolean): TSymStr;
{ Check whether a type can be used in a JVM methom signature or field
declaration. }
function jvmchecktype(def: tdef; out founderror: tdef): boolean;
{ incremental version of jvmtryencodetype() }
function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
{ add type prefix (package name) to a type }
procedure jvmaddtypeownerprefix(owner: tsymtable; var name: TSymStr);
{ returns type string for a single-dimensional array (different from normal
typestring in case of a primitive type) }
function jvmarrtype(def: tdef; out primitivetype: boolean): TSymStr;
function jvmarrtype_setlength(def: tdef): char;
{ returns whether a def is emulated using an implicit pointer type on the
JVM target (e.g., records, regular arrays, ...) }
function jvmimplicitpointertype(def: tdef): boolean;
{ returns the mangled base name for a tsym (type + symbol name, no
visibility etc); also adds signature attribute if requested and
appropriate }
function jvmmangledbasename(sym: tsym; withsignature: boolean): TSymStr;
function jvmmangledbasename(sym: tsym; const usesymname: TSymStr; withsignature: boolean): TSymStr;
{ sometimes primitive types have to be boxed/unboxed via class types. This
routine returns the appropriate box type for the passed primitive type }
procedure jvmgetboxtype(def: tdef; out objdef, paradef: tdef; mergeints: boolean);
function jvmgetunboxmethod(def: tdef): string;
function jvmgetcorrespondingclassdef(def: tdef): tdef;
function get_para_push_size(def: tdef): tdef;
{ threadvars are wrapped via descendents of java.lang.ThreadLocal }
function jvmgetthreadvardef(def: tdef): tdef;
{ gets the number of dimensions and the final element type of a normal
array }
procedure jvmgetarraydimdef(arrdef: tdef; out eledef: tdef; out ndim: longint);
{ the JVM specs require that you add a default parameterless
constructor in case the programmer hasn't specified any }
procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
implementation
uses
cutils,cclasses,constexp,
verbose,systems,
fmodule,
symtable,symconst,symsym,symcpu,symcreat,
pparautl,
defutil,paramgr;
{******************************************************************
Type encoding
*******************************************************************}
function jvmtypeneedssignature(def: tdef): boolean;
var
i: longint;
begin
result:=false;
case def.typ of
classrefdef,
setdef:
begin
result:=true;
end;
arraydef :
begin
result:=jvmtypeneedssignature(tarraydef(def).elementdef);
end;
procvardef :
begin
{ may change in the future }
end;
procdef :
begin
for i:=0 to tprocdef(def).paras.count-1 do
begin
result:=jvmtypeneedssignature(tparavarsym(tprocdef(def).paras[i]).vardef);
if result then
exit;
end;
end
else
result:=false;
end;
end;
procedure jvmaddencodedsignature(def: tdef; bpacked: boolean; var encodedstr: TSymStr);
var
founderror: tdef;
begin
case def.typ of
pointerdef :
begin
{ maybe one day }
internalerror(2011051403);
end;
classrefdef :
begin
{ Ljava/lang/Class<+SomeClassType> means
"Ljava/lang/Class<SomeClassType_or_any_of_its_descendents>" }
encodedstr:=encodedstr+'Ljava/lang/Class<+';
jvmaddencodedtype(tclassrefdef(def).pointeddef,false,encodedstr,true,founderror);
encodedstr:=encodedstr+'>;';
end;
setdef :
begin
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
if is_array_of_const(def) then
begin
internalerror(2011051405);
end
else if is_packed_array(def) then
begin
internalerror(2011051406);
end
else
begin
encodedstr:=encodedstr+'[';
jvmaddencodedsignature(tarraydef(def).elementdef,false,encodedstr);
end;
end;
procvardef :
begin
{ maybe one day }
internalerror(2011051407);
end;
objectdef :
begin
{ maybe one day }
end;
undefineddef,
errordef :
begin
internalerror(2011051408);
end;
procdef :
{ must be done via jvmencodemethod() }
internalerror(2011051401);
else
internalerror(2011051402);
end;
end;
function jvmaddencodedtype(def: tdef; bpacked: boolean; var encodedstr: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
var
c: char;
begin
result:=true;
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
{ translated into java.lang.String }
st_widestring,
st_unicodestring:
result:=jvmaddencodedtype(java_jlstring,false,encodedstr,forcesignature,founderror);
st_ansistring:
result:=jvmaddencodedtype(java_ansistring,false,encodedstr,forcesignature,founderror);
st_shortstring:
result:=jvmaddencodedtype(java_shortstring,false,encodedstr,forcesignature,founderror);
else
{ May be handled via wrapping later }
result:=false;
end;
end;
enumdef:
begin
result:=jvmaddencodedtype(tcpuenumdef(tenumdef(def).getbasedef).classdef,false,encodedstr,forcesignature,founderror);
end;
orddef :
begin
{ for procedure "results" }
if is_void(def) then
c:='V'
{ only Pascal-style booleans conform to Java's definition of
Boolean }
else if is_pasbool(def) and
(def.size=1) then
c:='Z'
else if is_widechar(def) then
c:='C'
else
begin
case def.size of
1:
c:='B';
2:
c:='S';
4:
c:='I';
8:
c:='J';
else
internalerror(2010121905);
end;
end;
encodedstr:=encodedstr+c;
end;
pointerdef :
begin
if is_voidpointer(def) then
result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror)
else if jvmimplicitpointertype(tpointerdef(def).pointeddef) then
result:=jvmaddencodedtype(tpointerdef(def).pointeddef,false,encodedstr,forcesignature,founderror)
else
begin
{ all pointer types are emulated via arrays }
encodedstr:=encodedstr+'[';
result:=jvmaddencodedtype(tpointerdef(def).pointeddef,false,encodedstr,forcesignature,founderror);
end
end;
floatdef :
begin
case tfloatdef(def).floattype of
s32real:
c:='F';
s64real:
c:='D';
else
begin
result:=false;
c:=' ';
end;
end;
encodedstr:=encodedstr+c;
end;
filedef :
begin
case tfiledef(def).filetyp of
ft_text:
result:=jvmaddencodedtype(search_system_type('TEXTREC').typedef,false,encodedstr,forcesignature,founderror);
ft_typed,
ft_untyped:
result:=jvmaddencodedtype(search_system_type('FILEREC').typedef,false,encodedstr,forcesignature,founderror);
end;
end;
recorddef :
begin
encodedstr:=encodedstr+'L'+trecorddef(def).jvm_full_typename(true)+';'
end;
variantdef :
begin
{ will be hanlded via wrapping later, although wrapping may
happen at higher level }
result:=false;
end;
classrefdef :
begin
if not forcesignature then
{ unfortunately, java.lang.Class is final, so we can't create
different versions for difference class reference types }
encodedstr:=encodedstr+'Ljava/lang/Class;'
{ we can however annotate it with extra signature information in
using Java's generic annotations }
else
jvmaddencodedsignature(def,false,encodedstr);
result:=true;
end;
setdef :
begin
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
result:=jvmaddencodedtype(java_jubitset,false,encodedstr,forcesignature,founderror)
end;
formaldef :
begin
{ var/const/out x: JLObject }
result:=jvmaddencodedtype(java_jlobject,false,encodedstr,forcesignature,founderror);
end;
arraydef :
begin
if is_array_of_const(def) then
begin
encodedstr:=encodedstr+'[';
result:=jvmaddencodedtype(search_system_type('TVARREC').typedef,false,encodedstr,forcesignature,founderror);
end
else if is_packed_array(def) then
result:=false
else
begin
encodedstr:=encodedstr+'[';
if not jvmaddencodedtype(tarraydef(def).elementdef,false,encodedstr,forcesignature,founderror) then
begin
result:=false;
{ report the exact (nested) error defintion }
exit;
end;
end;
end;
procvardef :
begin
result:=jvmaddencodedtype(tcpuprocvardef(def).classdef,false,encodedstr,forcesignature,founderror);
end;
objectdef :
case tobjectdef(def).objecttype of
odt_javaclass,
odt_interfacejava:
begin
def:=maybe_find_real_class_definition(def,false);
encodedstr:=encodedstr+'L'+tobjectdef(def).jvm_full_typename(true)+';'
end
else
result:=false;
end;
undefineddef,
errordef :
result:=false;
procdef :
{ must be done via jvmencodemethod() }
internalerror(2010121903);
else
internalerror(2010121904);
end;
if not result then
founderror:=def;
end;
function jvmtryencodetype(def: tdef; out encodedtype: TSymStr; forcesignature: boolean; out founderror: tdef): boolean;
begin
encodedtype:='';
result:=jvmaddencodedtype(def,false,encodedtype,forcesignature,founderror);
end;
procedure jvmaddtypeownerprefix(owner: tsymtable; var name: TSymStr);
var
owningcontainer: tsymtable;
tmpresult: TSymStr;
module: tmodule;
nameendpos: longint;
begin
{ see tprocdef.jvmmangledbasename for description of the format }
owningcontainer:=owner;
while (owningcontainer.symtabletype=localsymtable) do
owningcontainer:=owningcontainer.defowner.owner;
case owningcontainer.symtabletype of
globalsymtable,
staticsymtable:
begin
module:=find_module_from_symtable(owningcontainer);
tmpresult:='';
if assigned(module.namespace) then
tmpresult:=module.namespace^+'/';
tmpresult:=tmpresult+module.realmodulename^+'/';
end;
objectsymtable:
case tobjectdef(owningcontainer.defowner).objecttype of
odt_javaclass,
odt_interfacejava:
begin
tmpresult:=tobjectdef(owningcontainer.defowner).jvm_full_typename(true)+'/'
end
else
internalerror(2010122606);
end;
recordsymtable:
tmpresult:=trecorddef(owningcontainer.defowner).jvm_full_typename(true)+'/'
else
internalerror(2010122605);
end;
name:=tmpresult+name;
nameendpos:=pos(' ',name);
if nameendpos=0 then
nameendpos:=length(name)+1;
insert('''',name,nameendpos);
name:=''''+name;
end;
function jvmarrtype(def: tdef; out primitivetype: boolean): TSymStr;
var
errdef: tdef;
begin
if not jvmtryencodetype(def,result,false,errdef) then
internalerror(2011012201);
primitivetype:=false;
if length(result)=1 then
begin
case result[1] of
'Z': result:='boolean';
'C': result:='char';
'B': result:='byte';
'S': result:='short';
'I': result:='int';
'J': result:='long';
'F': result:='float';
'D': result:='double';
else
internalerror(2011012203);
end;
primitivetype:=true;
end
else if (result[1]='L') then
begin
{ in case of a class reference, strip the leading 'L' and the
trailing ';' }
setlength(result,length(result)-1);
delete(result,1,1);
end;
{ for arrays, use the actual reference type }
end;
function jvmarrtype_setlength(def: tdef): char;
var
errdef: tdef;
res: TSymStr;
begin
{ keep in sync with rtl/java/jdynarrh.inc and usage in njvminl }
if is_record(def) then
result:='R'
else if is_shortstring(def) then
result:='T'
else if def.typ=setdef then
begin
if tsetdef(def).elementdef.typ=enumdef then
result:='E'
else
result:='L'
end
else if (def.typ=procvardef) and
not tprocvardef(def).is_addressonly then
result:='P'
else
begin
if not jvmtryencodetype(def,res,false,errdef) then
internalerror(2011012209);
if length(res)=1 then
result:=res[1]
else
result:='A';
end;
end;
function jvmimplicitpointertype(def: tdef): boolean;
begin
case def.typ of
arraydef:
result:=(tarraydef(def).highrange>=tarraydef(def).lowrange) or
is_open_array(def) or
is_array_of_const(def) or
is_array_constructor(def) or
is_conststring_array(def);
filedef,
recorddef,
setdef:
result:=true;
objectdef:
result:=is_object(def);
stringdef :
result:=tstringdef(def).stringtype in [st_shortstring,st_longstring];
procvardef:
result:=not tprocvardef(def).is_addressonly;
else
result:=false;
end;
end;
{ mergeints = true means that all integer types are mapped to jllong,
otherwise they are mapped to the closest corresponding type }
procedure jvmgetboxtype(def: tdef; out objdef, paradef: tdef; mergeints: boolean);
begin
case def.typ of
orddef:
begin
case torddef(def).ordtype of
pasbool1,
pasbool8:
begin
objdef:=tobjectdef(search_system_type('JLBOOLEAN').typedef);
paradef:=pasbool8type;
end;
uwidechar:
begin
objdef:=tobjectdef(search_system_type('JLCHARACTER').typedef);
paradef:=cwidechartype;
end;
else
begin
{ wrap all integer types into a JLLONG, so that we don't get
errors after returning a byte assigned to a long etc }
if mergeints or
(torddef(def).ordtype in [s64bit,u64bit,scurrency,bool64bit,pasbool64]) then
begin
objdef:=tobjectdef(search_system_type('JLLONG').typedef);
paradef:=s64inttype;
end
else
begin
case torddef(def).ordtype of
s8bit,
u8bit,
uchar,
bool8bit:
begin
objdef:=tobjectdef(search_system_type('JLBYTE').typedef);
paradef:=s8inttype;
end;
s16bit,
u16bit,
bool16bit,
pasbool16:
begin
objdef:=tobjectdef(search_system_type('JLSHORT').typedef);
paradef:=s16inttype;
end;
s32bit,
u32bit,
bool32bit,
pasbool32:
begin
objdef:=tobjectdef(search_system_type('JLINTEGER').typedef);
paradef:=s32inttype;
end;
else
internalerror(2011052101);
end;
end;
end;
end;
end;
floatdef:
begin
case tfloatdef(def).floattype of
s32real:
begin
objdef:=tobjectdef(search_system_type('JLFLOAT').typedef);
paradef:=s32floattype;
end;
s64real:
begin
objdef:=tobjectdef(search_system_type('JLDOUBLE').typedef);
paradef:=s64floattype;
end;
else
internalerror(2011052102);
end;
end;
else
internalerror(2011052103);
end;
end;
function jvmgetunboxmethod(def: tdef): string;
begin
case def.typ of
orddef:
begin
case torddef(def).ordtype of
pasbool1,
pasbool8:
result:='BOOLEANVALUE';
s8bit,
u8bit,
uchar,
bool8bit:
result:='BYTEVALUE';
s16bit,
u16bit,
bool16bit,
pasbool16:
result:='SHORTVALUE';
s32bit,
u32bit,
bool32bit,
pasbool32:
result:='INTVALUE';
s64bit,
u64bit,
scurrency,
bool64bit,
pasbool64:
result:='LONGVALUE';
uwidechar:
result:='CHARVALUE';
else
internalerror(2011071702);
end;
end;
floatdef:
begin
case tfloatdef(def).floattype of
s32real:
result:='FLOATVALUE';
s64real:
result:='DOUBLEVALUE';
else
internalerror(2011071703);
end;
end;
else
internalerror(2011071704);
end;
end;
function jvmgetcorrespondingclassdef(def: tdef): tdef;
var
paradef: tdef;
begin
if def.typ in [orddef,floatdef] then
jvmgetboxtype(def,result,paradef,false)
else
begin
case def.typ of
stringdef :
begin
case tstringdef(def).stringtype of
{ translated into java.lang.String }
st_widestring,
st_unicodestring:
result:=java_jlstring;
st_ansistring:
result:=java_ansistring;
st_shortstring:
result:=java_shortstring;
else
internalerror(2011072409);
end;
end;
enumdef:
begin
result:=tcpuenumdef(tenumdef(def).getbasedef).classdef;
end;
pointerdef :
begin
if def=voidpointertype then
result:=java_jlobject
else if jvmimplicitpointertype(tpointerdef(def).pointeddef) then
result:=tpointerdef(def).pointeddef
else
internalerror(2011072410);
end;
recorddef :
begin
result:=def;
end;
variantdef :
begin
result:=cvarianttype;
end;
classrefdef :
begin
result:=search_system_type('JLCLASS').typedef;
end;
setdef :
begin
if tsetdef(def).elementdef.typ=enumdef then
result:=java_juenumset
else
result:=java_jubitset;
end;
formaldef :
begin
result:=java_jlobject;
end;
arraydef :
begin
{ cannot represent statically }
internalerror(2011072411);
end;
procvardef :
begin
result:=tcpuprocvardef(def).classdef;
end;
objectdef :
case tobjectdef(def).objecttype of
odt_javaclass,
odt_interfacejava:
result:=def
else
internalerror(2011072412);
end;
else
internalerror(2011072413);
end;
end;
end;
function get_para_push_size(def: tdef): tdef;
begin
result:=def;
if def.typ=orddef then
case torddef(def).ordtype of
u8bit,uchar:
if torddef(def).high>127 then
result:=s8inttype;
u16bit:
begin
if torddef(def).high>32767 then
result:=s16inttype;
end
else
;
end;
end;
function jvmgetthreadvardef(def: tdef): tdef;
begin
if (def.typ=arraydef) and
not is_dynamic_array(def) then
begin
result:=search_system_type('FPCNORMALARRAYTHREADVAR').typedef;
exit;
end;
if jvmimplicitpointertype(def) then
begin
result:=search_system_type('FPCIMPLICITPTRTHREADVAR').typedef;
exit;
end;
case def.typ of
orddef:
begin
case torddef(def).ordtype of
pasbool1,
pasbool8:
begin
result:=tobjectdef(search_system_type('FPCBOOLEANTHREADVAR').typedef);
end;
uwidechar:
begin
result:=tobjectdef(search_system_type('FPCCHARTHREADVAR').typedef);
end;
s8bit,
u8bit,
uchar,
bool8bit:
begin
result:=tobjectdef(search_system_type('FPCBYTETHREADVAR').typedef);
end;
s16bit,
u16bit,
bool16bit,
pasbool16:
begin
result:=tobjectdef(search_system_type('FPCSHORTTHREADVAR').typedef);
end;
s32bit,
u32bit,
bool32bit,
pasbool32:
begin
result:=tobjectdef(search_system_type('FPCINTTHREADVAR').typedef);
end;
s64bit,
u64bit,
scurrency,
bool64bit,
pasbool64:
begin
result:=tobjectdef(search_system_type('FPCLONGTHREADVAR').typedef);
end
else
internalerror(2011082101);
end;
end;
floatdef:
begin
case tfloatdef(def).floattype of
s32real:
begin
result:=tobjectdef(search_system_type('FPCFLOATTHREADVAR').typedef);
end;
s64real:
begin
result:=tobjectdef(search_system_type('FPCDOUBLETHREADVAR').typedef);
end;
else
internalerror(2011082102);
end;
end
else
begin
result:=search_system_type('FPCPOINTERTHREADVAR').typedef
end;
end;
end;
procedure jvmgetarraydimdef(arrdef: tdef; out eledef: tdef; out ndim: longint);
begin
eledef:=arrdef;
ndim:=0;
repeat
eledef:=tarraydef(eledef).elementdef;
inc(ndim);
until (eledef.typ<>arraydef) or
is_dynamic_array(eledef);
end;
function jvmmangledbasename(sym: tsym; const usesymname: TSymStr; withsignature: boolean): TSymStr;
var
container: tsymtable;
vsym: tabstractvarsym;
csym: tconstsym;
usedef: tdef;
begin
case sym.typ of
staticvarsym,
paravarsym,
localvarsym,
fieldvarsym:
begin
vsym:=tabstractvarsym(sym);
{ for local and paravarsyms that are unsigned 8/16 bit, change the
outputted type to signed 16/32 bit:
a) the stack slots are all 32 bit anyway, so the storage allocation
is still correct
b) since at the JVM level all types are signed, this makes sure
that the values in the stack slots are valid for the specified
types
}
usedef:=vsym.vardef;
if vsym.typ in [localvarsym,paravarsym] then
begin
if (usedef.typ=orddef) then
case torddef(usedef).ordtype of
u8bit,uchar:
usedef:=s16inttype;
u16bit:
usedef:=s32inttype;
else
;
end;
end;
result:=jvmencodetype(usedef,false);
if withsignature and
jvmtypeneedssignature(usedef) then
begin
result:=result+' signature "';
result:=result+jvmencodetype(usedef,true)+'"';
end;
if (vsym.typ=paravarsym) and
(vo_is_self in tparavarsym(vsym).varoptions) then
result:='''this'' ' +result
else if (vsym.typ in [paravarsym,localvarsym]) and
([vo_is_funcret,vo_is_result] * tabstractnormalvarsym(vsym).varoptions <> []) then
result:='''result'' '+result
else
begin
{ add array indirection if required }
if (vsym.typ=paravarsym) and
((usedef.typ=formaldef) or
((vsym.varspez in [vs_var,vs_out,vs_constref]) and
not jvmimplicitpointertype(usedef))) then
result:='['+result;
{ single quotes for definitions to prevent clashes with Java
opcodes }
if withsignature then
result:=usesymname+''' '+result
else
result:=usesymname+' '+result;
{ we have to mangle staticvarsyms in localsymtables to
prevent name clashes... }
if (vsym.typ=staticvarsym) then
begin
container:=sym.Owner;
while (container.symtabletype=localsymtable) do
begin
if tdef(container.defowner).typ<>procdef then
internalerror(2011040303);
{ unique_id_str is added to prevent problem with overloads }
result:=tprocdef(container.defowner).procsym.realname+'$$'+tprocdef(container.defowner).unique_id_str+'$'+result;
container:=container.defowner.owner;
end;
end;
if withsignature then
result:=''''+result
end;
end;
constsym:
begin
csym:=tconstsym(sym);
{ some constants can be untyped }
if assigned(csym.constdef) and
not(csym.consttyp in [constwstring,conststring]) then
begin
result:=jvmencodetype(csym.constdef,false);
if withsignature and
jvmtypeneedssignature(csym.constdef) then
begin
result:=result+' signature "';
result:=result+jvmencodetype(csym.constdef,true)+'"';
end;
end
else
begin
case csym.consttyp of
constord:
result:=jvmencodetype(s32inttype,withsignature);
constreal:
result:=jvmencodetype(s64floattype,withsignature);
constset:
internalerror(2011040701);
constpointer,
constnil:
result:=jvmencodetype(java_jlobject,withsignature);
constwstring,
conststring:
result:=jvmencodetype(java_jlstring,withsignature);
constresourcestring:
internalerror(2011040702);
else
internalerror(2011040703);
end;
end;
if withsignature then
result:=''''+usesymname+''' '+result
else
result:=usesymname+' '+result
end;
else
internalerror(2011021703);
end;
end;
function jvmmangledbasename(sym: tsym; withsignature: boolean): TSymStr;
begin
if (sym.typ=fieldvarsym) and
assigned(tfieldvarsym(sym).externalname) then
result:=jvmmangledbasename(sym,tfieldvarsym(sym).externalname^,withsignature)
else if (sym.typ=staticvarsym) and
(tstaticvarsym(sym).mangledbasename<>'') then
result:=jvmmangledbasename(sym,tstaticvarsym(sym).mangledbasename,withsignature)
else
result:=jvmmangledbasename(sym,sym.RealName,withsignature);
end;
{******************************************************************
jvm type validity checking
*******************************************************************}
function jvmencodetype(def: tdef; withsignature: boolean): TSymStr;
var
errordef: tdef;
begin
if not jvmtryencodetype(def,result,withsignature,errordef) then
internalerror(2011012305);
end;
function jvmchecktype(def: tdef; out founderror: tdef): boolean;
var
encodedtype: TSymStr;
begin
{ don't duplicate the code like in objcdef, since the resulting strings
are much shorter here so it's not worth it }
result:=jvmtryencodetype(def,encodedtype,false,founderror);
end;
{******************************************************************
Adding extra methods
*******************************************************************}
procedure maybe_add_public_default_java_constructor(obj: tabstractrecorddef);
var
sym: tsym;
ps: tprocsym;
pd: tprocdef;
topowner: tdefentry;
i: longint;
sstate: tscannerstate;
needclassconstructor: boolean;
begin
ps:=nil;
{ if there is at least one constructor for a class, do nothing (for
records, we'll always also need a parameterless constructor) }
if not is_javaclass(obj) or
not (oo_has_constructor in obj.objectoptions) then
begin
{ check whether the parent has a parameterless constructor that we can
call (in case of a class; all records will derive from
java.lang.Object or a shim on top of that with a parameterless
constructor) }
if is_javaclass(obj) then
begin
pd:=nil;
{ childof may not be assigned in case of a parser error }
if not assigned(tobjectdef(obj).childof) then
exit;
sym:=tsym(tobjectdef(obj).childof.symtable.find('CREATE'));
if assigned(sym) and
(sym.typ=procsym) then
pd:=tprocsym(sym).find_bytype_parameterless(potype_constructor);
if not assigned(pd) then
begin
Message(sym_e_no_matching_inherited_parameterless_constructor);
exit
end;
end;
{ we call all constructors CREATE, because they don't have a name in
Java and otherwise we can't determine whether multiple overloads
are created with the same parameters }
sym:=tsym(obj.symtable.find('CREATE'));
if assigned(sym) then
begin
{ does another, non-procsym, symbol already exist with that name? }
if (sym.typ<>procsym) then
begin
Message1(sym_e_duplicate_id_create_java_constructor,sym.realname);
exit;
end;
ps:=tprocsym(sym);
{ is there already a parameterless function/procedure create? }
pd:=ps.find_bytype_parameterless(potype_function);
if not assigned(pd) then
pd:=ps.find_bytype_parameterless(potype_procedure);
if assigned(pd) then
begin
Message1(sym_e_duplicate_id_create_java_constructor,pd.fullprocname(false));
exit;
end;
end;
if not assigned(sym) then
begin
ps:=cprocsym.create('Create');
obj.symtable.insertsym(ps);
end;
{ determine symtable level }
topowner:=obj;
while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable]) do
topowner:=topowner.owner.defowner;
{ create procdef }
pd:=cprocdef.create(topowner.owner.symtablelevel+1,true);
if df_generic in obj.defoptions then
include(pd.defoptions,df_generic);
{ method of this objectdef }
pd.struct:=obj;
{ associated procsym }
pd.procsym:=ps;
{ constructor }
pd.proctypeoption:=potype_constructor;
{ needs to be exported }
include(pd.procoptions,po_global);
{ by default do not include this routine when looking for overloads }
include(pd.procoptions,po_ignore_for_overload_resolution);
{ generate anonymous inherited call in the implementation }
pd.synthetickind:=tsk_anon_inherited;
{ public }
pd.visibility:=vis_public;
{ result type }
pd.returndef:=obj;
{ calling convention }
if assigned(current_structdef) or
(assigned(pd.owner.defowner) and
(pd.owner.defowner.typ=recorddef)) then
handle_calling_convention(pd,hcc_default_actions_intf_struct)
else
handle_calling_convention(pd,hcc_default_actions_intf);
{ register forward declaration with procsym }
proc_add_definition(pd);
end;
{ also add class constructor if class fields that need wrapping, and
if none was defined }
if obj.find_procdef_bytype(potype_class_constructor)=nil then
begin
needclassconstructor:=false;
for i:=0 to obj.symtable.symlist.count-1 do
begin
if (tsym(obj.symtable.symlist[i]).typ=staticvarsym) and
jvmimplicitpointertype(tstaticvarsym(obj.symtable.symlist[i]).vardef) then
begin
needclassconstructor:=true;
break;
end;
end;
if needclassconstructor then
begin
replace_scanner('custom_class_constructor',sstate);
if str_parse_method_dec('constructor fpc_jvm_class_constructor;',potype_class_constructor,true,obj,pd) then
pd.synthetickind:=tsk_empty
else
internalerror(2011040501);
restore_scanner(sstate);
end;
end;
end;
end.