From e1d0e7572ea253b14f1644faeca76e8b26b0931d Mon Sep 17 00:00:00 2001 From: nickysn Date: Thu, 5 Apr 2018 15:09:12 +0000 Subject: [PATCH] * i8086 TP7 compatibility fixes, related to obtaining procedure addresses: o The @ and Addr() operators in TP or Delphi mode can now be applied to both near and far procedures and they always produce a CodePointer, regardless of the call model of the procedure. o Ofs() and Seg() can now also be applied to both near and far procedures. o The @ and Addr() operators in non-TP/Delphi modes, as well as the procedure name itself in TP/Delphi modes now can be applied to both near and far procedures and produce a near or a far procvar. git-svn-id: trunk@38691 - --- .gitattributes | 1 + compiler/i8086/n8086cnv.pas | 27 +++---- compiler/ncgcnv.pas | 6 +- compiler/nmem.pas | 2 +- tests/test/cpu16/i8086/tprocaddr1.pp | 114 +++++++++++++++++++++++++++ 5 files changed, 129 insertions(+), 21 deletions(-) create mode 100644 tests/test/cpu16/i8086/tprocaddr1.pp diff --git a/.gitattributes b/.gitattributes index ee64a549ef..90faa72769 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12253,6 +12253,7 @@ tests/test/cpu16/i8086/tmmm.pp svneol=native#text/pascal tests/test/cpu16/i8086/tmms.pp svneol=native#text/pascal tests/test/cpu16/i8086/tmmt.pp svneol=native#text/pascal tests/test/cpu16/i8086/tprcdat1.pp svneol=native#text/plain +tests/test/cpu16/i8086/tprocaddr1.pp svneol=native#text/plain tests/test/cpu16/i8086/tptrcon.pp svneol=native#text/pascal tests/test/cpu16/i8086/tptrsize.pp svneol=native#text/pascal tests/test/cpu16/i8086/tra1.pp svneol=native#text/pascal diff --git a/compiler/i8086/n8086cnv.pas b/compiler/i8086/n8086cnv.pas index 18f5996fd6..89b8065870 100644 --- a/compiler/i8086/n8086cnv.pas +++ b/compiler/i8086/n8086cnv.pas @@ -65,35 +65,28 @@ implementation function t8086typeconvnode.typecheck_proc_to_procvar: tnode; begin - if (current_settings.x86memorymodel in x86_far_code_models) and - not is_proc_far(tabstractprocdef(left.resultdef)) then - CGMessage1(type_e_procedure_must_be_far,left.resultdef.GetTypeName); Result:=inherited typecheck_proc_to_procvar; if tcnf_proc_2_procvar_get_offset_only in convnodeflags then begin if resultdef.typ<>procvardef then internalerror(2018040401); exclude(tprocvardef(resultdef).procoptions,po_far); + end + else if (tcnf_proc_2_procvar_2_voidpointer in convnodeflags) and + (current_settings.x86memorymodel in x86_far_code_models) then + begin + if resultdef.typ<>procvardef then + internalerror(2018040402); + include(tprocvardef(resultdef).procoptions,po_far); end; end; procedure t8086typeconvnode.second_proc_to_procvar; begin - if tcnf_proc_2_procvar_get_offset_only in convnodeflags then - begin - if is_proc_far(tabstractprocdef(resultdef)) then - internalerror(2018040402); - end - else - begin - if is_proc_far(tabstractprocdef(resultdef))<> - (current_settings.x86memorymodel in x86_far_code_models) then - internalerror(2014041302); - end; - if is_proc_far(tabstractprocdef(left.resultdef))<> - (current_settings.x86memorymodel in x86_far_code_models) then - internalerror(2014041303); + if (tcnf_proc_2_procvar_get_offset_only in convnodeflags) and + is_proc_far(tabstractprocdef(resultdef)) then + internalerror(2018040403); inherited; end; diff --git a/compiler/ncgcnv.pas b/compiler/ncgcnv.pas index be55a1acea..15aa94d74a 100644 --- a/compiler/ncgcnv.pas +++ b/compiler/ncgcnv.pas @@ -548,18 +548,18 @@ interface begin if tabstractprocdef(resultdef).is_addressonly then begin - location_reset(location,LOC_REGISTER,def_cgsize(tabstractprocdef(resultdef).address_type)); + location_reset(location,LOC_REGISTER,def_cgsize(resultdef)); { only a code pointer? (when taking the address of classtype.method we also only get a code pointer even though the resultdef is a procedure of object, and hence is_addressonly would return false) } - if left.location.size = def_cgsize(tabstractprocdef(resultdef).address_type) then + if left.location.size = def_cgsize(tabstractprocdef(left.resultdef).address_type) then begin case left.location.loc of LOC_REFERENCE,LOC_CREFERENCE: begin { the procedure symbol is encoded in reference.symbol -> take address } - location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,tabstractprocdef(resultdef).address_type); + location.register:=hlcg.getaddressregister(current_asmdata.CurrAsmList,resultdef); hlcg.a_loadaddr_ref_reg(current_asmdata.CurrAsmList,left.resultdef,resultdef,left.location.reference,location.register); end; else diff --git a/compiler/nmem.pas b/compiler/nmem.pas index bf2b5b6076..c29090ac95 100644 --- a/compiler/nmem.pas +++ b/compiler/nmem.pas @@ -582,7 +582,7 @@ implementation if anf_ofs in addrnodeflags then result:=ctypeconvnode.create_internal(left,tabstractprocdef(left.resultdef).ofs_address_type) else - result:=ctypeconvnode.create_internal(left,tabstractprocdef(left.resultdef).address_type); + result:=ctypeconvnode.create_internal(left,voidcodepointertype); include(result.flags,nf_load_procvar); left:=nil; end diff --git a/tests/test/cpu16/i8086/tprocaddr1.pp b/tests/test/cpu16/i8086/tprocaddr1.pp new file mode 100644 index 0000000000..74b67a5709 --- /dev/null +++ b/tests/test/cpu16/i8086/tprocaddr1.pp @@ -0,0 +1,114 @@ +{ test applies only to these memory models: } +{$if defined(FPC_MM_MEDIUM) or defined(FPC_MM_LARGE) or defined(FPC_MM_HUGE)} + +{$mode TP} + +{$F-} + +{ should be near, since we are in $F- mode } +procedure myproc; +begin + Writeln('myproc'); +end; + +procedure mynearproc; near; +begin + Writeln('mynearproc'); +end; + +procedure myfarproc; far; +begin + Writeln('myfarproc'); +end; + +type + TMyObject = object + procedure RegularMethod; + end; + +procedure TMyObject.RegularMethod; +begin + Writeln('TMyObject.RegularMethod'); +end; + +procedure Error; +begin + Writeln('Error!'); + Halt(1); +end; + +var + prcn: Procedure; near; + prc: Procedure; + prcf: Procedure; far; + ptr_prcn: Word absolute prcn; + ptr_prc: FarPointer absolute prc; + ptr_prcf: FarPointer absolute prcf; + w: Word; + P, PA: CodePointer; +begin + prcn := myproc; + prcn; + prcn := mynearproc; + prcn; + prc := myfarproc; + prc; + prcf := myfarproc; + prcf; + + prcn := myproc; + w := Ofs(myproc); + P := @myproc; + PA := Addr(myproc); + if ptr_prcn <> w then + Error; + if P <> PA then + Error; + if Ofs(P^) <> w then + Error; + if Seg(P^) <> Seg(myproc) then + Error; + + prcn := mynearproc; + w := Ofs(mynearproc); + P := @mynearproc; + PA := Addr(mynearproc); + if ptr_prcn <> w then + Error; + if P <> PA then + Error; + if Ofs(P^) <> w then + Error; + if Seg(P^) <> Seg(mynearproc) then + Error; + + prcf := myfarproc; + w := Ofs(myfarproc); + P := @myfarproc; + PA := Addr(myfarproc); + if ptr_prcf <> P then + Error; + if P <> PA then + Error; + if Ofs(P^) <> w then + Error; + if Seg(P^) <> Seg(myfarproc) then + Error; + + P := @TMyObject.RegularMethod; + PA := Addr(TMyObject.RegularMethod); + w := Ofs(TMyObject.RegularMethod); + if P <> PA then + Error; + if Ofs(P^) <> w then + Error; + if Seg(P^) <> Seg(TMyObject.RegularMethod) then + Error; + + Writeln('Ok!'); +end. +{$else} +begin + { silently succeed in the other memory models } +end. +{$endif} \ No newline at end of file