+ show an error message 'procedure must be far' if an attempt is made to convert

a near proc to a procvar in a i8086 far code memory model

git-svn-id: trunk@27567 -

compiler/i8086/n8086cnv.pas

@@ -29,8 +29,12 @@ interface
       node,ncgcnv,nx86cnv,defutil,defcmp;
 
     type
+
+       { t8086typeconvnode }
+
        t8086typeconvnode = class(tx86typeconvnode)
        protected
+         function typecheck_proc_to_procvar: tnode;override;
          procedure second_proc_to_procvar;override;
          procedure second_nil_to_methodprocvar;override;
        end;
@@ -48,6 +52,14 @@ implementation
       cgutils,cgobj,hlcgobj,cgx86,ncgutil,
       tgobj;
 
+    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;
+      end;
+
 
     procedure t8086typeconvnode.second_proc_to_procvar;
       var
@@ -56,10 +68,15 @@ implementation
       begin
         if not is_proc_far(tabstractprocdef(resultdef)) then
           begin
+            if current_settings.x86memorymodel in x86_far_code_models then
+              internalerror(2014041302);
             inherited;
             exit;
           end;
 
+        if not is_proc_far(tabstractprocdef(left.resultdef)) then
+          internalerror(2014041303);
+
         if tabstractprocdef(resultdef).is_addressonly then
           begin
             location_reset(location,LOC_REGISTER,OS_32);

compiler/msg/errore.msg

@@ -1514,7 +1514,7 @@ parser_e_overloaded_have_same_mangled_name=03336_E_Overloaded routines have the
 %
 # Type Checking
 #
-# 04120 is the last used one
+# 04121 is the last used one
 #
 % \section{Type checking errors}
 % This section lists all errors that can occur when type checking is
@@ -1938,6 +1938,9 @@ type_e_invalid_default_value=04119_E_It is not possible to define a default valu
 % arrays and TP-style objects, cannot have a default value.
 type_e_type_not_allowed_for_type_helper=04120_E_Type "$1" cannot be extended by a type helper
 % Types like procedural variables cannot be extended by type helpers
+type_e_procedure_must_be_far=04121_E_Procedure or function must be far in order to allow taking its address: "$1"
+% In certain i8086 memory models (medium, large and huge), procedures and functions
+% have to be declared 'far' in order to allow their address to be taken.
 % \end{description}
 #
 # Symtable

compiler/msgidx.inc

@@ -546,6 +546,7 @@ const
   type_e_typeof_requires_vmt=04118;
   type_e_invalid_default_value=04119;
   type_e_type_not_allowed_for_type_helper=04120;
+  type_e_procedure_must_be_far=04121;
   sym_e_id_not_found=05000;
   sym_f_internal_error_in_symtablestack=05001;
   sym_e_duplicate_id=05002;
@@ -986,9 +987,9 @@ const
   option_info=11024;
   option_help_pages=11025;
 
-  MsgTxtSize = 71242;
+  MsgTxtSize = 71327;
 
   MsgIdxMax : array[1..20] of longint=(
-    26,96,337,121,89,57,126,27,202,64,
+    26,96,337,122,89,57,126,27,202,64,
     57,20,1,1,1,1,1,1,1,1
   );