* 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

@@ -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

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;
 

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

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

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}