+ added an i8086-specific FarAddr() function, similar to Addr(), but always

  returns a far pointer, regardless of the current memory model

git-svn-id: trunk@37628 -

.gitattributes

@@ -12140,6 +12140,7 @@ tests/test/cpu16/i8086/tasmabs4.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tasmabs5.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tasmseg1.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tasmseg2.pp svneol=native#text/pascal
+tests/test/cpu16/i8086/tfaradr1.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tfarcal1.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tfarcal2.pp svneol=native#text/pascal
 tests/test/cpu16/i8086/tfarcal3.pp svneol=native#text/plain

compiler/compinnr.pas

@@ -116,6 +116,7 @@ type
      in_neg_assign_x      = 94,
      in_not_assign_x      = 95,
      in_gettypekind_x     = 96,
+     in_faraddr_x         = 97,
 
 { Internal constant functions }
      in_const_sqr        = 100,

compiler/i8086/n8086inl.pas

@@ -33,6 +33,8 @@ interface
        { ti8086inlinenode }
 
        ti8086inlinenode = class(tx86inlinenode)
+         function pass_typecheck_cpu: tnode; override;
+         function typecheck_faraddr: tnode;
          function typecheck_seg: tnode; override;
          function first_seg: tnode; override;
          procedure second_seg; override;
@@ -56,11 +58,47 @@ implementation
     symtype,symdef,symcpu,
     cgbase,pass_1,pass_2,
     cpuinfo,cpubase,paramgr,
-    nbas,nadd,ncon,ncal,ncnv,nld,ncgutil,
+    nbas,nadd,ncon,ncal,ncnv,nld,nmem,nmat,ncgutil,
     tgobj,
     cga,cgutils,cgx86,cgobj,hlcgobj,
     htypechk,procinfo;
 
+     function ti8086inlinenode.pass_typecheck_cpu: tnode;
+       begin
+         case inlinenumber of
+           in_faraddr_x:
+             result:=typecheck_faraddr;
+           else
+             inherited;
+         end;
+       end;
+
+     function ti8086inlinenode.typecheck_faraddr: tnode;
+       var
+         addr_node: tnode;
+         addr_node_resultdef: tdef;
+         seg_node: tnode;
+       begin
+         addr_node:=caddrnode.create(left);
+         typecheckpass(addr_node);
+         addr_node_resultdef:=addr_node.resultdef;
+         if is_farpointer(addr_node.resultdef) or is_farprocvar(addr_node.resultdef) then
+           begin
+             left:=nil;
+             result:=addr_node;
+           end
+         else
+           begin
+             seg_node:=geninlinenode(in_seg_x,false,left.getcopy);
+             inserttypeconv_internal(seg_node,u32inttype);
+             seg_node:=cshlshrnode.create(shln,seg_node,cordconstnode.create(16,u8inttype,false));
+             inserttypeconv_internal(addr_node,u32inttype);
+             left:=nil;
+             result:=caddnode.create(addn,seg_node,addr_node);
+             inserttypeconv_internal(result,tcpupointerdef.getreusablex86(addr_node_resultdef,x86pt_far));
+           end;
+       end;
+
      function ti8086inlinenode.typecheck_seg: tnode;
        begin
          result := nil;

compiler/pexpr.pas

@@ -599,6 +599,22 @@ implementation
               statement_syssym:=p1;
             end;
 
+{$ifdef i8086}
+          in_faraddr_x :
+            begin
+              consume(_LKLAMMER);
+              got_addrn:=true;
+              p1:=factor(true,[]);
+              { inside parentheses a full expression is allowed, see also tests\webtbs\tb27517.pp }
+              if token<>_RKLAMMER then
+                p1:=sub_expr(opcompare,[ef_accept_equal],p1);
+              p1:=geninlinenode(in_faraddr_x,false,p1);
+              got_addrn:=false;
+              consume(_RKLAMMER);
+              statement_syssym:=p1;
+            end;
+{$endif i8086}
+
           in_ofs_x :
             begin
               if target_info.system in systems_managed_vm then

compiler/psystem.pas

@@ -87,6 +87,9 @@ implementation
         systemunit.insert(csyssym.create('Assert',in_assert_x_y));
         systemunit.insert(csyssym.create('Val',in_val_x));
         systemunit.insert(csyssym.create('Addr',in_addr_x));
+{$ifdef i8086}
+        systemunit.insert(csyssym.create('FarAddr',in_faraddr_x));
+{$endif i8086}
         systemunit.insert(csyssym.create('TypeInfo',in_typeinfo_x));
         systemunit.insert(csyssym.create('SetLength',in_setlength_x));
         systemunit.insert(csyssym.create('Copy',in_copy_x));

rtl/inc/innr.inc

@@ -104,6 +104,7 @@ const
    fpc_in_ror_assign_x_y    = 93;
    fpc_in_neg_assign_x      = 94;
    fpc_in_not_assign_x      = 95;
+   fpc_in_faraddr_x         = 97;
 
 { Internal constant functions }
    fpc_in_const_sqr        = 100;

tests/test/cpu16/i8086/tfaradr1.pp

@@ -0,0 +1,40 @@
+{ %cpu=i8086 }
+
+program tfaradr1;
+
+var
+  global_variable: Integer;
+
+procedure Fail(const S: string);
+begin
+  Writeln('Error in FarAddr(', S, ')');
+  Halt(1);
+end;
+
+procedure test_local_variable;
+var
+  local_variable: Integer;
+begin
+  if FarAddr(local_variable) <> Ptr(Seg(local_variable), Ofs(local_variable)) then
+    Fail('local_variable');
+end;
+
+procedure proc;
+begin
+  Writeln('Hi, i''m a proc.');
+end;
+
+var
+  proc_addr: FarPointer;
+begin
+  if FarAddr(global_variable) <> Ptr(Seg(global_variable), Ofs(global_variable)) then
+    Fail('global_variable');
+
+  test_local_variable;
+
+  proc_addr := FarAddr(proc);
+  if proc_addr <> Ptr(Seg(proc), Ofs(proc)) then
+    Fail('proc');
+
+  Writeln('Ok!');
+end.