paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-12 12:50:31 +02:00
Code Issues Packages Projects Releases Wiki Activity
aee5380ae0
fpc/compiler/jvm/pjvm.pas
Jonas Maebe aee5380ae0 * merged trunk up to r20882 
o support for the new codepage-aware ansistrings in the jvm branch
   o empty ansistrings are now always represented by a nil pointer rather than
     by an empty string, because an empty string also has a code page which
     can confuse code (although this will make ansistrings harder to use
     in Java code)
   o more string helpers code shared between the general and jvm rtl
   o support for indexbyte/word in the jvm rtl (warning: first parameter
     is an open array rather than an untyped parameter there, so
     indexchar(pcharvar^,10,0) will be equivalent to
     indexchar[pcharvar^],10,0) there, which is different from what is
     intended; changing it to an untyped parameter wouldn't help though)
   o default() support is not yet complete
   o calling fpcres is currently broken due to limitations in
     sysutils.executeprocess() regarding handling unix quoting and
     the compiler using the same command lines for scripts and directly
     calling external programs
   o compiling the Java compiler currently requires adding ALLOW_WARNINGS=1
     to the make command line

git-svn-id: branches/jvmbackend@20887 -
2012-04-15 15:54:10 +00:00

978 lines
43 KiB
ObjectPascal
Raw 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) 2011 by Jonas Maebe
This unit implements some JVM parser helper routines.
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 pjvm;
interface
uses
globtype,
symconst,symtype,symbase,symdef,symsym;
{ 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);
{ records are emulated via Java classes. They require a default constructor
to initialise temps, a deep copy helper for assignments, and clone()
to initialse dynamic arrays }
procedure add_java_default_record_methods_intf(def: trecorddef);
procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
procedure jvm_wrap_virtual_class_methods(obj: tobjectdef);
function jvm_add_typed_const_initializer(csym: tconstsym): tstaticvarsym;
function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
{ when a private/protected field is exposed via a property with a higher
visibility, then we have to create a getter and/or setter with that same
higher visibility to make sure that using the property does not result
in JVM verification errors }
procedure jvm_create_getter_for_property(p: tpropertysym);
procedure jvm_create_setter_for_property(p: tpropertysym);
implementation
uses
cutils,cclasses,
verbose,systems,
fmodule,
parabase,aasmdata,
pdecsub,ngenutil,pparautl,
symtable,symcreat,defcmp,jvmdef,nobj,
defutil,paramgr;
{ 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);
var
sym: tsym;
ps: tprocsym;
pd: tprocdef;
topowner: tdefentry;
i: longint;
sstate: tscannerstate;
needclassconstructor: boolean;
begin
{ 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:=tprocsym.create('Create');
obj.symtable.insert(ps);
end;
{ determine symtable level }
topowner:=obj;
while not(topowner.owner.symtabletype in [staticsymtable,globalsymtable]) do
topowner:=topowner.owner.defowner;
{ create procdef }
pd:=tprocdef.create(topowner.owner.symtablelevel+1);
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, self, ... (not for advanced records, for those
this is handled later) }
if obj.typ=recorddef then
handle_calling_convention(pd,[hcc_check])
else
handle_calling_convention(pd,hcc_all);
{ 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;
procedure add_java_default_record_methods_intf(def: trecorddef);
var
sstate: tscannerstate;
pd: tprocdef;
sym: tsym;
i: longint;
begin
maybe_add_public_default_java_constructor(def);
replace_scanner('record_jvm_helpers',sstate);
{ no override, because not supported in records. Only required in case
some of the fields require deep copies (otherwise the default
shallow clone is fine) }
for i:=0 to def.symtable.symlist.count-1 do
begin
sym:=tsym(def.symtable.symlist[i]);
if (sym.typ=fieldvarsym) and
jvmimplicitpointertype(tfieldvarsym(sym).vardef) then
begin
if str_parse_method_dec('function clone: JLObject;',potype_function,false,def,pd) then
pd.synthetickind:=tsk_jvm_clone
else
internalerror(2011032806);
break;
end;
end;
{ can't use def.typesym, not yet set at this point }
if not assigned(def.symtable.realname) then
internalerror(2011032803);
if str_parse_method_dec('procedure fpcDeepCopy(result: FpcBaseRecordType);',potype_procedure,false,def,pd) then
begin
pd.synthetickind:=tsk_record_deepcopy;
{ can't add to the declaration since record methods can't override;
it is in fact an overriding method, because all records inherit
from a Java base class }
include(pd.procoptions,po_overridingmethod);
end
else
internalerror(2011032807);
if def.needs_inittable then
begin
{ 'var' instead of 'out' parameter, because 'out' would trigger
calling the initialize method recursively }
if str_parse_method_dec('procedure fpcInitializeRec;',potype_procedure,false,def,pd) then
pd.synthetickind:=tsk_record_initialize
else
internalerror(2011071711);
end;
restore_scanner(sstate);
end;
procedure setup_for_new_class(const scannername: string; out sstate: tscannerstate; out islocal: boolean; out oldsymtablestack: TSymtablestack);
begin
replace_scanner(scannername,sstate);
oldsymtablestack:=symtablestack;
islocal:=symtablestack.top.symtablelevel>=normal_function_level;
if islocal then
begin
{ we cannot add a class local to a procedure -> insert it in the
static symtable. This is not ideal because this means that it will
be saved to the ppu file for no good reason, and loaded again
even though it contains a reference to a type that was never
saved to the ppu file (the locally defined enum type). Since this
alias for the locally defined enumtype is only used while
implementing the class' methods, this is however no problem. }
symtablestack:=symtablestack.getcopyuntil(current_module.localsymtable);
end;
end;
procedure restore_after_new_class(const sstate: tscannerstate; const islocal: boolean; const oldsymtablestack: TSymtablestack);
begin
if islocal then
begin
symtablestack.free;
symtablestack:=oldsymtablestack;
end;
restore_scanner(sstate);
end;
procedure jvm_maybe_create_enum_class(const name: TIDString; def: tdef);
var
vmtbuilder: tvmtbuilder;
arrdef: tarraydef;
arrsym: ttypesym;
juhashmap: tdef;
enumclass: tobjectdef;
pd: tprocdef;
old_current_structdef: tabstractrecorddef;
i: longint;
sym,
aliassym: tstaticvarsym;
fsym: tfieldvarsym;
sstate: tscannerstate;
sl: tpropaccesslist;
temptypesym: ttypesym;
oldsymtablestack: tsymtablestack;
islocal: boolean;
begin
{ if it's a subrange type, don't create a new class }
if assigned(tenumdef(def).basedef) then
exit;
setup_for_new_class('jvm_enum_class',sstate,islocal,oldsymtablestack);
{ create new class (different internal name than enum to prevent name
clash; at unit level because we don't want its methods to be nested
inside a function in case its a local type) }
enumclass:=tobjectdef.create(odt_javaclass,'$'+current_module.realmodulename^+'$'+name+'$InternEnum$'+tostr(def.defid),java_jlenum);
tenumdef(def).classdef:=enumclass;
include(enumclass.objectoptions,oo_is_enum_class);
include(enumclass.objectoptions,oo_is_sealed);
{ implement FpcEnumValueObtainable interface }
enumclass.ImplementedInterfaces.add(TImplementedInterface.Create(tobjectdef(search_system_type('FPCENUMVALUEOBTAINABLE').typedef)));
{ create an alias for this type inside itself: this way we can choose a
name that can be used in generated Pascal code without risking an
identifier conflict (since it is local to this class; the global name
is unique because it's an identifier that contains $-signs) }
enumclass.symtable.insert(ttypesym.create('__FPC_TEnumClassAlias',enumclass));
{ also create an alias for the enum type so that we can iterate over
all enum values when creating the body of the class constructor }
temptypesym:=ttypesym.create('__FPC_TEnumAlias',nil);
{ don't pass def to the ttypesym constructor, because then it
will replace the current (real) typesym of that def with the alias }
temptypesym.typedef:=def;
enumclass.symtable.insert(temptypesym);
{ but the name of the class as far as the JVM is concerned will match
the enum's original name (the enum type itself won't be output in
any class file, so no conflict there)
name can be empty in case of declaration such as "set of (ea,eb)" }
if not islocal and
(name <> '') then
enumclass.objextname:=stringdup(name)
else
{ for local types, use a unique name to prevent conflicts (since such
types are not visible outside the routine anyway, it doesn't matter
}
begin
enumclass.objextname:=stringdup(enumclass.objrealname^);
{ also mark it as private (not strict private, because the class
is not a subclass of the unit in which it is declared, so then
the unit's procedures would not be able to use it) }
enumclass.typesym.visibility:=vis_private;
end;
{ now add a bunch of extra things to the enum class }
old_current_structdef:=current_structdef;
current_structdef:=enumclass;
symtablestack.push(enumclass.symtable);
{ create static fields representing all enums }
for i:=0 to tenumdef(def).symtable.symlist.count-1 do
begin
fsym:=tfieldvarsym.create(tenumsym(tenumdef(def).symtable.symlist[i]).realname,vs_final,enumclass,[]);
enumclass.symtable.insert(fsym);
sym:=make_field_static(enumclass.symtable,fsym);
{ add alias for the field representing ordinal(0), for use in
initialization code }
if tenumsym(tenumdef(def).symtable.symlist[i]).value=0 then
begin
aliassym:=tstaticvarsym.create('__FPC_Zero_Initializer',vs_final,enumclass,[vo_is_external]);
enumclass.symtable.insert(aliassym);
aliassym.set_raw_mangledname(sym.mangledname);
end;
end;
{ create local "array of enumtype" type for the "values" functionality
(used internally by the JDK) }
arrdef:=tarraydef.create(0,tenumdef(def).symtable.symlist.count-1,s32inttype);
arrdef.elementdef:=enumclass;
arrsym:=ttypesym.create('__FPC_TEnumValues',arrdef);
enumclass.symtable.insert(arrsym);
{ insert "public static values: array of enumclass" that returns $VALUES.clone()
(rather than a dynamic array and using clone --which we don't support yet for arrays--
simply use a fixed length array and copy it) }
if not str_parse_method_dec('function values: __FPC_TEnumValues;static;',potype_function,true,enumclass,pd) then
internalerror(2011062301);
include(pd.procoptions,po_staticmethod);
pd.synthetickind:=tsk_jvm_enum_values;
{ do we have to store the ordinal value separately? (if no jumps, we can
just call the default ordinal() java.lang.Enum function) }
if tenumdef(def).has_jumps then
begin
{ add field for the value }
fsym:=tfieldvarsym.create('__fpc_fenumval',vs_final,s32inttype,[]);
enumclass.symtable.insert(fsym);
tobjectsymtable(enumclass.symtable).addfield(fsym,vis_strictprivate);
{ add class field with hash table that maps from FPC-declared ordinal value -> enum instance }
juhashmap:=search_system_type('JUHASHMAP').typedef;
fsym:=tfieldvarsym.create('__fpc_ord2enum',vs_final,juhashmap,[]);
enumclass.symtable.insert(fsym);
make_field_static(enumclass.symtable,fsym);
{ add custom constructor }
if not str_parse_method_dec('constructor Create(const __fpc_name: JLString; const __fpc_ord, __fpc_initenumval: longint);',potype_constructor,false,enumclass,pd) then
internalerror(2011062401);
pd.synthetickind:=tsk_jvm_enum_jumps_constr;
pd.visibility:=vis_strictprivate;
end
else
begin
{ insert "private constructor(string,int,int)" that calls inherited and
initialises the FPC value field }
add_missing_parent_constructors_intf(enumclass,false,vis_strictprivate);
end;
{ add instance method to get the enum's value as declared in FPC }
if not str_parse_method_dec('function FPCOrdinal: longint;',potype_function,false,enumclass,pd) then
internalerror(2011062402);
pd.synthetickind:=tsk_jvm_enum_fpcordinal;
{ add static class method to convert an ordinal to the corresponding enum }
if not str_parse_method_dec('function FPCValueOf(__fpc_int: longint): __FPC_TEnumClassAlias; static;',potype_function,true,enumclass,pd) then
internalerror(2011062402);
pd.synthetickind:=tsk_jvm_enum_fpcvalueof;
{ similar (instance) function for use in set factories; implements FpcEnumValueObtainable interface }
if not str_parse_method_dec('function fpcGenericValueOf(__fpc_int: longint): JLEnum;',potype_function,false,enumclass,pd) then
internalerror(2011062402);
pd.synthetickind:=tsk_jvm_enum_fpcvalueof;
{ insert "public static valueOf(string): tenumclass" that returns tenumclass(inherited valueOf(tenumclass,string)) }
if not str_parse_method_dec('function valueOf(const __fpc_str: JLString): __FPC_TEnumClassAlias; static;',potype_function,true,enumclass,pd) then
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
check for a conflict with "VALUES" ($<id> normally means "check for
<id> without uppercasing first"), which will conflict with the
"Values" instance method -- that's also the reason why we insert the
field only now, because we cannot disable duplicate identifier
checking when creating the "Values" method }
fsym:=tfieldvarsym.create('$VALUES',vs_final,arrdef,[]);
fsym.visibility:=vis_strictprivate;
enumclass.symtable.insert(fsym,false);
sym:=make_field_static(enumclass.symtable,fsym);
{ alias for accessing the field in generated Pascal code }
sl:=tpropaccesslist.create;
sl.addsym(sl_load,sym);
enumclass.symtable.insert(tabsolutevarsym.create_ref('__fpc_FVALUES',arrdef,sl));
{ add initialization of the static class fields created above }
if not str_parse_method_dec('constructor fpc_enum_class_constructor;',potype_class_constructor,true,enumclass,pd) then
internalerror(2011062303);
pd.synthetickind:=tsk_jvm_enum_classconstr;
symtablestack.pop(enumclass.symtable);
vmtbuilder:=TVMTBuilder.Create(enumclass);
vmtbuilder.generate_vmt;
vmtbuilder.free;
restore_after_new_class(sstate,islocal,oldsymtablestack);
current_structdef:=old_current_structdef;
end;
procedure jvm_create_procvar_class_intern(const name: TIDString; def: tdef; force_no_callback_intf: boolean);
var
vmtbuilder: tvmtbuilder;
oldsymtablestack: tsymtablestack;
pvclass,
pvintf: tobjectdef;
temptypesym: ttypesym;
sstate: tscannerstate;
methoddef: tprocdef;
old_current_structdef: tabstractrecorddef;
islocal: boolean;
begin
{ inlined definition of procvar -> generate name, derive from
FpcBaseNestedProcVarType, pass nestedfpstruct to constructor and
copy it }
if name='' then
internalerror(2011071901);
setup_for_new_class('jvm_pvar_class',sstate,islocal,oldsymtablestack);
{ create new class (different internal name than pvar to prevent name
clash; at unit level because we don't want its methods to be nested
inside a function in case its a local type) }
pvclass:=tobjectdef.create(odt_javaclass,'$'+current_module.realmodulename^+'$'+name+'$InternProcvar$'+tostr(def.defid),java_procvarbase);
tprocvardef(def).classdef:=pvclass;
include(pvclass.objectoptions,oo_is_sealed);
if df_generic in def.defoptions then
include(pvclass.defoptions,df_generic);
{ associate typesym }
pvclass.symtable.insert(ttypesym.create('__FPC_TProcVarClassAlias',pvclass));
{ set external name to match procvar type name }
if not islocal then
pvclass.objextname:=stringdup(name)
else
pvclass.objextname:=stringdup(pvclass.objrealname^);
symtablestack.push(pvclass.symtable);
{ inherit constructor and keep public }
add_missing_parent_constructors_intf(pvclass,true,vis_public);
{ add a method to call the procvar using unwrapped arguments, which
then wraps them and calls through to JLRMethod.invoke }
methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
finish_copied_procdef(methoddef,'invoke',pvclass.symtable,pvclass);
insert_self_and_vmt_para(methoddef);
methoddef.synthetickind:=tsk_jvm_procvar_invoke;
methoddef.calcparas;
{ add local alias for the procvartype that we can use when implementing
the invoke method }
temptypesym:=ttypesym.create('__FPC_ProcVarAlias',nil);
{ don't pass def to the ttypesym constructor, because then it
will replace the current (real) typesym of that def with the alias }
temptypesym.typedef:=def;
pvclass.symtable.insert(temptypesym);
{ in case of a procedure of object, add a nested interface type that
has one method that conforms to the procvartype (with name
procvartypename+'Callback') and an extra constructor that takes
an instance conforming to this interface and which sets up the
procvar by taking the address of its Callback method (convenient to
use from Java code) }
if (po_methodpointer in tprocvardef(def).procoptions) and
not islocal and
not force_no_callback_intf then
begin
pvintf:=tobjectdef.create(odt_interfacejava,'Callback',nil);
pvintf.objextname:=stringdup('Callback');
if df_generic in def.defoptions then
include(pvintf.defoptions,df_generic);
{ associate typesym }
pvclass.symtable.insert(ttypesym.create('Callback',pvintf));
{ add a method prototype matching the procvar (like the invoke
in the procvarclass itself) }
symtablestack.push(pvintf.symtable);
methoddef:=tprocdef(tprocvardef(def).getcopyas(procdef,pc_bareproc));
finish_copied_procdef(methoddef,name+'Callback',pvintf.symtable,pvintf);
insert_self_and_vmt_para(methoddef);
{ can't be final/static/private/protected, and must be virtual
since it's an interface method }
methoddef.procoptions:=methoddef.procoptions-[po_staticmethod,po_finalmethod];
include(methoddef.procoptions,po_virtualmethod);
methoddef.visibility:=vis_public;
symtablestack.pop(pvintf.symtable);
{ add an extra constructor to the procvarclass that takes an
instance of this interface as parameter }
old_current_structdef:=current_structdef;
current_structdef:=pvclass;
if not str_parse_method_dec('constructor Create(__intf:'+pvintf.objextname^+');overload;',potype_constructor,false,pvclass,methoddef) then
internalerror(2011092401);
methoddef.synthetickind:=tsk_jvm_procvar_intconstr;
methoddef.skpara:=def;
current_structdef:=old_current_structdef;
end;
symtablestack.pop(pvclass.symtable);
vmtbuilder:=TVMTBuilder.Create(pvclass);
vmtbuilder.generate_vmt;
vmtbuilder.free;
restore_after_new_class(sstate,islocal,oldsymtablestack);
end;
procedure jvm_create_procvar_class(const name: TIDString; def: tdef);
begin
jvm_create_procvar_class_intern(name,def,false);
end;
procedure jvm_wrap_virtual_class_method(pd: tprocdef);
var
wrapperpd: tprocdef;
wrapperpv: tprocvardef;
typ: ttypesym;
wrappername: shortstring;
begin
if (po_external in pd.procoptions) or
(oo_is_external in pd.struct.objectoptions) then
exit;
{ the JVM does not support virtual class methods -> we generate
wrappers with the original name so they can be called normally,
and these wrappers will then perform a dynamic lookup. To enable
calling the class method by its intended name from external Java code,
we have to change its external name so that we give that original
name to the wrapper function -> "switch" the external names around for
the original and wrapper methods }
{ replace importname of original procdef }
include(pd.procoptions,po_has_importname);
if not assigned(pd.import_name) then
wrappername:=pd.procsym.realname
else
wrappername:=pd.import_name^;
stringdispose(pd.import_name);
pd.import_name:=stringdup(wrappername+'__fpcvirtualclassmethod__');
{ wrapper is part of the same symtable as the original procdef }
symtablestack.push(pd.owner);
{ get a copy of the virtual class method }
wrapperpd:=tprocdef(pd.getcopy);
{ this one is not virtual nor override }
exclude(wrapperpd.procoptions,po_virtualmethod);
exclude(wrapperpd.procoptions,po_overridingmethod);
{ import/external name = name of original class method }
stringdispose(wrapperpd.import_name);
wrapperpd.import_name:=stringdup(wrappername);
include(wrapperpd.procoptions,po_has_importname);
{ associate with wrapper procsym (Pascal-level name = wrapper name ->
in callnodes, we will have to replace the calls to virtual class
methods with calls to the wrappers) }
finish_copied_procdef(wrapperpd,pd.import_name^,pd.owner,tabstractrecorddef(pd.owner.defowner));
{ we only have to generate the dispatching routine for non-overriding
methods; the overriding ones can use the original one, but generate
a skeleton for that anyway because the overriding one may still
change the visibility (but we can just call the inherited routine
in that case) }
if po_overridingmethod in pd.procoptions then
begin
{ by default do not include this routine when looking for overloads }
include(wrapperpd.procoptions,po_ignore_for_overload_resolution);
wrapperpd.synthetickind:=tsk_anon_inherited;
symtablestack.pop(pd.owner);
exit;
end;
{ implementation }
wrapperpd.synthetickind:=tsk_jvm_virtual_clmethod;
wrapperpd.skpara:=pd;
{ also create procvar type that we can use in the implementation }
wrapperpv:=tprocvardef(pd.getcopyas(procvardef,pc_normal));
wrapperpv.calcparas;
{ no use in creating a callback wrapper here, this procvar type isn't
for public consumption }
jvm_create_procvar_class_intern('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv,true);
{ create alias for the procvar type so we can use it in generated
Pascal code }
typ:=ttypesym.create('__fpc_virtualclassmethod_pv_t'+tostr(wrapperpd.defid),wrapperpv);
wrapperpv.classdef.typesym.visibility:=vis_strictprivate;
symtablestack.top.insert(typ);
symtablestack.pop(pd.owner);
end;
procedure jvm_wrap_virtual_constructor(pd: tprocdef);
var
wrapperpd: tprocdef;
begin
{ to avoid having to implement procvar-like support for dynamically
invoking constructors, call the constructors from virtual class
methods and replace calls to the constructors with calls to the
virtual class methods -> we can reuse lots of infrastructure }
if (po_external in pd.procoptions) or
(oo_is_external in pd.struct.objectoptions) then
exit;
{ wrapper is part of the same symtable as the original procdef }
symtablestack.push(pd.owner);
{ get a copy of the constructor }
wrapperpd:=tprocdef(pd.getcopyas(procdef,pc_bareproc));
{ this one is a class method rather than a constructor }
include(wrapperpd.procoptions,po_classmethod);
wrapperpd.proctypeoption:=potype_function;
wrapperpd.returndef:=tobjectdef(pd.owner.defowner);
{ import/external name = name of original constructor (since
constructors don't have names in Java, this won't conflict with the
original constructor definition) }
stringdispose(wrapperpd.import_name);
wrapperpd.import_name:=stringdup(pd.procsym.realname);
{ associate with wrapper procsym (Pascal-level name = wrapper name ->
in callnodes, we will have to replace the calls to virtual
constructors with calls to the wrappers) }
finish_copied_procdef(wrapperpd,pd.procsym.realname+'__fpcvirtconstrwrapper__',pd.owner,tabstractrecorddef(pd.owner.defowner));
{ since it was a bare copy, insert the self parameter (we can't just
copy the vmt parameter from the constructor, that's different) }
insert_self_and_vmt_para(wrapperpd);
wrapperpd.calcparas;
{ implementation: call through to the constructor
Exception: if the current class is abstract, do not call the
constructor, since abstract class cannot be constructed (and the
Android verifier does not accept such code, even if it is
unreachable) }
wrapperpd.synthetickind:=tsk_callthrough_nonabstract;
wrapperpd.skpara:=pd;
symtablestack.pop(pd.owner);
{ and now wrap this generated virtual static method itself as well }
jvm_wrap_virtual_class_method(wrapperpd);
end;
procedure jvm_wrap_virtual_class_methods(obj: tobjectdef);
var
i: longint;
def: tdef;
begin
{ new methods will be inserted while we do this, but since
symtable.deflist.count is evaluated at the start of the loop that
doesn't matter }
for i:=0 to obj.symtable.deflist.count-1 do
begin
def:=tdef(obj.symtable.deflist[i]);
if def.typ<>procdef then
continue;
if [po_classmethod,po_virtualmethod]<=tprocdef(def).procoptions then
jvm_wrap_virtual_class_method(tprocdef(def))
else if (tprocdef(def).proctypeoption=potype_constructor) and
(po_virtualmethod in tprocdef(def).procoptions) then
jvm_wrap_virtual_constructor(tprocdef(def));
end;
end;
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:
begin
{ make sure we don't emit a definition for this field (we'll do
that for the constsym already) -> mark as external }
ssym:=tstaticvarsym.create(internal_static_field_name(csym.realname),vs_final,csym.constdef,[vo_is_external]);
csym.owner.insert(ssym);
{ alias storage to the constsym }
ssym.set_mangledname(csym.realname);
for i:=0 to tenumdef(csym.constdef).symtable.symlist.count-1 do
begin
esym:=tenumsym(tenumdef(csym.constdef).symtable.symlist[i]);
if esym.value=csym.value.valueord.svalue then
break;
esym:=nil;
end;
{ can happen in case of explicit typecast from integer constant
to enum type }
if not assigned(esym) then
begin
MessagePos(csym.fileinfo,parser_e_range_check_error);
exit;
end;
replace_scanner('jvm_enum_const',sstate);
str_parse_typedconst(current_asmdata.asmlists[al_typedconsts],esym.name+';',ssym);
restore_scanner(sstate);
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;
end;
function jvm_wrap_method_with_vis(pd: tprocdef; vis: tvisibility): tprocdef;
var
obj: tabstractrecorddef;
visname: string;
begin
obj:=current_structdef;
{ if someone gets the idea to add a property to an external class
definition, don't try to wrap it since we cannot add methods to
external classes }
if oo_is_external in obj.objectoptions then
begin
result:=pd;
exit
end;
symtablestack.push(obj.symtable);
result:=tprocdef(pd.getcopy);
result.visibility:=vis;
visname:=visibilityName[vis];
replace(visname,' ','_');
{ create a name that is unique amongst all units (start with '$unitname$$') and
unique in this unit (result.defid) }
finish_copied_procdef(result,'$'+current_module.realmodulename^+'$$'+tostr(result.defid)+pd.procsym.realname+'$'+visname,obj.symtable,obj);
{ in case the referred method is from an external class }
exclude(result.procoptions,po_external);
{ not virtual/override/abstract/... }
result.procoptions:=result.procoptions*[po_classmethod,po_staticmethod,po_varargs,po_public];
result.synthetickind:=tsk_callthrough;
{ so we know the name of the routine to call through to }
result.skpara:=pd;
symtablestack.pop(obj.symtable);
end;
procedure jvm_create_getter_or_setter_for_property(p: tpropertysym; getter: boolean);
var
obj: tabstractrecorddef;
ps: tprocsym;
pvs: tparavarsym;
pd: tprocdef;
tmpaccesslist: tpropaccesslist;
callthroughpropname,
name: string;
callthroughprop: tpropertysym;
accesstyp: tpropaccesslisttypes;
begin
obj:=current_structdef;
{ if someone gets the idea to add a property to an external class
definition, don't try to wrap it since we cannot add methods to
external classes }
if oo_is_external in obj.objectoptions then
exit;
symtablestack.push(obj.symtable);
if getter then
accesstyp:=palt_read
else
accesstyp:=palt_write;
{ create a property for the old symaccesslist with a new name, so that
we can reuse it in the implementation (rather than having to
translate the symaccesslist back to Pascal code) }
callthroughpropname:='__fpc__'+p.realname;
if getter then
callthroughpropname:=callthroughpropname+'__getter_wrapper'
else
callthroughpropname:=callthroughpropname+'__setter_wrapper';
callthroughprop:=tpropertysym.create(callthroughpropname);
callthroughprop.visibility:=p.visibility;
callthroughprop.default:=longint($80000000);
if sp_static in p.symoptions then
include(callthroughprop.symoptions, sp_static);
{ copy original property target to callthrough property (and replace
original one with the new empty list; will be filled in later) }
tmpaccesslist:=callthroughprop.propaccesslist[accesstyp];
callthroughprop.propaccesslist[accesstyp]:=p.propaccesslist[accesstyp];
p.propaccesslist[accesstyp]:=tmpaccesslist;
p.owner.insert(callthroughprop);
{ we can't use str_parse_method_dec here because the type of the field
may not be visible at the Pascal level }
{ create procdef }
pd:=tprocdef.create(normal_function_level);
if df_generic in obj.defoptions then
include(pd.defoptions,df_generic);
{ construct procsym name (unique for this access; reusing the same
helper for multiple accesses to the same field is hard because the
propacesslist can contain subscript nodes etc) }
name:=visibilityName[p.visibility];
replace(name,' ','_');
if getter then
name:=name+'$getter'
else
name:=name+'$setter';
name:='$'+obj.symtable.realname^+'$'+p.realname+'$'+name+'$'+tostr(pd.defid);
{ new procsym }
ps:=tprocsym.create(name);
obj.symtable.insert(ps);
{ associate procsym with procdef}
pd.procsym:=ps;
{ method of this objectdef }
pd.struct:=obj;
{ visibility }
pd.visibility:=p.visibility;
{ function/procedure }
if getter then
begin
pd.proctypeoption:=potype_function;
pd.synthetickind:=tsk_field_getter;
{ result type }
pd.returndef:=p.propdef;
end
else
begin
pd.proctypeoption:=potype_procedure;
pd.synthetickind:=tsk_field_setter;
pd.returndef:=voidtype;
{ parameter with value to set }
pvs:=tparavarsym.create('__fpc_newval__',10,vs_const,p.propdef,[]);
pd.parast.insert(pvs);
end;
pd.skpara:=callthroughprop;
{ needs to be exported }
include(pd.procoptions,po_global);
{ class property -> static class method }
if sp_static in p.symoptions then
pd.procoptions:=pd.procoptions+[po_classmethod,po_staticmethod];
{ calling convention, self, ... }
if obj.typ=recorddef then
handle_calling_convention(pd,[hcc_check])
else
handle_calling_convention(pd,hcc_all);
{ register forward declaration with procsym }
proc_add_definition(pd);
{ make the property call this new function }
p.propaccesslist[accesstyp].addsym(sl_call,ps);
p.propaccesslist[accesstyp].procdef:=pd;
symtablestack.pop(obj.symtable);
end;
procedure jvm_create_getter_for_property(p: tpropertysym);
begin
jvm_create_getter_or_setter_for_property(p,true);
end;
procedure jvm_create_setter_for_property(p: tpropertysym);
begin
jvm_create_getter_or_setter_for_property(p,false);
end;
end.
Reference in New Issue View Git Blame Copy Permalink