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

+ dummy support for untyped var/const/out parameters on the JVM target

Browse Source 
o includes basic "auto-boxing" infrastructure to support Delphi.NET-
     compatible untyped parameters as described at
     http://hallvards.blogspot.com/2007/10/dn4dp24-net-vs-win32-untyped-parameters.html

git-svn-id: branches/jvmbackend@18510 -
This commit is contained in:
Jonas Maebe 2011-08-20 08:05:54 +00:00
parent 4c152ccb7d
commit 694ccf3df3
13 changed files with 443 additions and 343 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
compiler/compinnr.inc
View File

@ -83,6 +83,7 @@ const
in_sar_x = 73;
in_bsf_x = 74;
in_bsr_x = 75;
in_box_x = 76; { managed platforms: wrap in class instance }
{ Internal constant functions }
in_const_sqr = 100;

3
compiler/hlcgobj.pas
View File

@ -615,7 +615,8 @@ implementation
objectdef,
procvardef,
procdef,
arraydef :
arraydef,
formaldef:
result:=R_ADDRESSREGISTER;
floatdef:
if use_vectorfpu(def) then

7
compiler/htypechk.pas
View File

@ -1231,7 +1231,12 @@ implementation
- typecast from pointer to array }
fromdef:=ttypeconvnode(hp).left.resultdef;
todef:=hp.resultdef;
if not((nf_absolute in ttypeconvnode(hp).flags) or
{ in managed VMs, you cannot typecast formaldef when assigning
to it, see http://hallvards.blogspot.com/2007/10/dn4dp24-net-vs-win32-untyped-parameters.html }
if (target_info.system in systems_managed_vm) and
(fromdef.typ=formaldef) then
CGMessagePos(hp.fileinfo,type_e_no_managed_formal_assign_typecast)
else if not((nf_absolute in ttypeconvnode(hp).flags) or
(fromdef.typ=formaldef) or
is_void(fromdef) or
is_open_array(fromdef) or

33
compiler/jvm/njvminl.pas
View File

@ -38,6 +38,9 @@ interface
function first_copy: tnode; override;
function handle_box: tnode; override;
function first_box: tnode; override;
function first_setlength_array: tnode;
function first_setlength_string: tnode;
public
@ -72,6 +75,7 @@ interface
*)
procedure second_new; override;
procedure second_setlength; override;
procedure second_box; override;
protected
procedure load_fpu_location;
end;
@ -234,6 +238,23 @@ implementation
end;
function tjvminlinenode.handle_box: tnode;
begin
Result:=inherited;
resultdef:=java_jlobject;
end;
function tjvminlinenode.first_box: tnode;
begin
result:=nil;
expectloc:=LOC_REGISTER;
{$ifdef nounsupported}
internalerror(2011042603);
{$endif}
end;
function tjvminlinenode.pass_typecheck: tnode;
var
handled: boolean;
@ -721,6 +742,18 @@ implementation
thlcgjvm(hlcg).a_load_stack_loc(current_asmdata.CurrAsmList,target.resultdef,target.location);
end;
procedure tjvminlinenode.second_box;
begin
{$ifndef nounsupported}
secondpass(tcallparanode(left).left);
location_reset(location,LOC_REGISTER,OS_ADDR);
location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,java_jlobject);
hlcg.a_load_const_reg(current_asmdata.CurrAsmList,java_jlobject,0,location.register);
{$else}
internalerror(2011042606);
{$endif}
end;
begin
cinlinenode:=tjvminlinenode;

7
compiler/jvmdef.pas
View File

@ -190,8 +190,13 @@ implementation
end;
formaldef :
begin
{ not supported (may be changed into "java.lang.Object" later) }
{$ifndef nounsupported}
{ var x: JLObject }
encodedstr:=encodedstr+'[';
result:=jvmaddencodedtype(java_jlobject,false,encodedstr,founderror);
{$else}
result:=false;
{$endif}
end;
arraydef :
begin

11
compiler/msg/errore.msg
View File

@ -1423,7 +1423,7 @@ parser_d_internal_parser_string=03318_D_Parsing internally generated code: $1
% \end{description}
# Type Checking
#
# 04104 is the last used one
# 04105 is the last used one
#
% \section{Type checking errors}
% This section lists all errors that can occur when type checking is
@ -1786,6 +1786,15 @@ type_e_java_class_method_not_static=04103_E_Java class methods have to be static
% methods. It is not possible to declare non-static class methods.
type_e_invalid_final_assignment=04104_E_Final (class) fields can only be assigned in their class' (class) constructor
% It is only possible to assign a value to a final (class) field inside a (class) constructor of its owning class.
type_e_no_managed_formal_assign_typecast=04105_E_It is not possible to typecast untyped parameters on managed platforms, simply assign a value to them instead.
% On managed platforms, untyped parameters are translated by the compiler into
% the equivalent of \var{var x: BaseClassType}. Non-class-based types passed to
% such parameters are automatically wrapped (or boxed) in a class, and after the
% call the potentially modified value is assigned back to the original variable.
% On the caller side, changing untyped var/out parameters happens by simply assigning
% values to them (either class-based or primitive ones). On the caller side,
% they will be extracted and if their type does not match the original variable's,
% an exception will be raised.
%
%
% \end{description}

5
compiler/msgidx.inc
View File

@ -505,6 +505,7 @@ const
type_e_record_helper_must_extend_same_record=04102;
type_e_java_class_method_not_static=04103;
type_e_invalid_final_assignment=04104;
type_e_no_managed_formal_assign_typecast=04105;
sym_e_id_not_found=05000;
sym_f_internal_error_in_symtablestack=05001;
sym_e_duplicate_id=05002;
@ -909,9 +910,9 @@ const
option_info=11024;
option_help_pages=11025;
MsgTxtSize = 61729;
MsgTxtSize = 61848;
MsgIdxMax : array[1..20] of longint=(
26,89,319,105,87,54,111,23,202,63,
26,89,319,106,87,54,111,23,202,63,
49,20,1,1,1,1,1,1,1,1
);

666
compiler/msgtxt.inc
View File

File diff suppressed because it is too large Load Diff

12
compiler/ncal.pas
View File

@ -869,7 +869,17 @@ implementation
vs_out :
begin
if not valid_for_formal_var(left,true) then
CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list);
CGMessagePos(left.fileinfo,parser_e_illegal_parameter_list)
else if (target_info.system in systems_managed_vm) and
(left.resultdef.typ in [orddef,floatdef]) then
begin
left:=cinlinenode.create(in_box_x,false,ccallparanode.create(left,nil));
typecheckpass(left);
{$ifdef nounsupported}
{ TODO: unbox afterwards }
internalerror(2011042608);
{$endif}
end;
end;
vs_const :
begin

3
compiler/ncgcal.pas
View File

@ -216,7 +216,8 @@ implementation
push_value_para;
end
{ formal def }
else if (parasym.vardef.typ=formaldef) then
else if (parasym.vardef.typ=formaldef) and
not(target_info.system in systems_managed_vm) then
begin
{ allow passing of a constant to a const formaldef }
if (parasym.varspez=vs_const) and

3
compiler/ncginl.pas
View File

@ -59,6 +59,7 @@ interface
procedure second_bsfbsr; virtual;
procedure second_new; virtual;
procedure second_setlength; virtual; abstract;
procedure second_box; virtual; abstract;
end;
implementation
@ -179,6 +180,8 @@ implementation
second_new;
in_setlength_x:
second_setlength;
in_box_x:
second_box;
else internalerror(9);
end;
end;

15
compiler/ninl.pas
View File

@ -72,6 +72,9 @@ interface
by the JVM backend to create new dynamic arrays. }
function first_new: tnode; virtual;
function first_length: tnode; virtual;
function first_box: tnode; virtual; abstract;
function handle_box: tnode; virtual;
private
function handle_str: tnode;
function handle_reset_rewrite_typed: tnode;
@ -2895,6 +2898,10 @@ implementation
begin
result:=handle_objc_encode;
end;
in_box_x:
begin
result:=handle_box;
end;
else
internalerror(8);
end;
@ -3285,6 +3292,8 @@ implementation
expectloc:=LOC_REGISTER;
in_new_x:
result:=first_new;
in_box_x:
result:=first_box;
else
internalerror(89);
end;
@ -3568,6 +3577,12 @@ implementation
end;
end;
function tinlinenode.handle_box: tnode;
begin
result:=nil;
resultdef:=class_tobject;
end;
function tinlinenode.first_pack_unpack: tnode;
var
loopstatement : tstatementnode;

20
compiler/nld.pas
View File

@ -545,9 +545,23 @@ implementation
maybe_call_procvar(right,true);
{ assignments to formaldefs and open arrays aren't allowed }
if (left.resultdef.typ=formaldef) or
is_open_array(left.resultdef) then
CGMessage(type_e_assignment_not_allowed);
if is_open_array(left.resultdef) then
CGMessage(type_e_assignment_not_allowed)
else if (left.resultdef.typ=formaldef) then
if not(target_info.system in systems_managed_vm) then
CGMessage(type_e_assignment_not_allowed)
else
begin
{ on managed platforms, assigning to formaldefs is allowed (but
typecasting them on the left hand side isn't), but primitive
values need to be boxed first }
if (right.resultdef.typ in [orddef,floatdef]) then
begin
right:=cinlinenode.create(in_box_x,false,ccallparanode.create(right,nil));
typecheckpass(right);
end;
end;
{ test if node can be assigned, properties are allowed }
if not(nf_internal in flags) then