* handle the loading of VMT entries at the node level, so it's done in a

    type-safe way (for LLVM, and also internal consistency checking between
    the VMT as generated in nobj.pas and ncgvmt.pas)
   o also converted the VMT validity checking to the node level

git-svn-id: trunk@30950 -

compiler/cgobj.pas

@@ -348,7 +348,6 @@ unit cgobj;
           procedure optimize_op_const(size: TCGSize; var op: topcg; var a : tcgint);virtual;
 
 
-          procedure g_maybe_testvmt(list : TAsmList;reg:tregister;objdef:tobjectdef);
           {# This should emit the opcode to copy len bytes from the source
              to destination.
 
@@ -2185,52 +2184,6 @@ implementation
 {$endif cpuflags}
 
 
-    procedure tcg.g_maybe_testvmt(list : TAsmList;reg:tregister;objdef:tobjectdef);
-      var
-        hrefvmt : treference;
-        cgpara1,cgpara2 : TCGPara;
-        pd: tprocdef;
-      begin
-        cgpara1.init;
-        cgpara2.init;
-        if (cs_check_object in current_settings.localswitches) then
-         begin
-           pd:=search_system_proc('fpc_check_object_ext');
-           paramanager.getintparaloc(list,pd,1,cgpara1);
-           paramanager.getintparaloc(list,pd,2,cgpara2);
-           reference_reset_symbol(hrefvmt,current_asmdata.RefAsmSymbol(objdef.vmt_mangledname,AT_DATA),0,sizeof(pint));
-           if pd.is_pushleftright then
-             begin
-               a_load_reg_cgpara(list,OS_ADDR,reg,cgpara1);
-               a_loadaddr_ref_cgpara(list,hrefvmt,cgpara2);
-             end
-           else
-             begin
-               a_loadaddr_ref_cgpara(list,hrefvmt,cgpara2);
-               a_load_reg_cgpara(list,OS_ADDR,reg,cgpara1);
-             end;
-           paramanager.freecgpara(list,cgpara1);
-           paramanager.freecgpara(list,cgpara2);
-           allocallcpuregisters(list);
-           a_call_name(list,'fpc_check_object_ext',false);
-           deallocallcpuregisters(list);
-         end
-        else
-         if (cs_check_range in current_settings.localswitches) then
-          begin
-            pd:=search_system_proc('fpc_check_object');
-            paramanager.getintparaloc(list,pd,1,cgpara1);
-            a_load_reg_cgpara(list,OS_ADDR,reg,cgpara1);
-            paramanager.freecgpara(list,cgpara1);
-            allocallcpuregisters(list);
-            a_call_name(list,'fpc_check_object',false);
-            deallocallcpuregisters(list);
-          end;
-        cgpara1.done;
-        cgpara2.done;
-      end;
-
-
 {*****************************************************************************
                             Entry/Exit Code Functions
 *****************************************************************************}

compiler/jvm/njvmcal.pas

@@ -50,6 +50,7 @@ interface
          procedure extra_post_call_code; override;
          function dispatch_procvar: tnode;
          procedure remove_hidden_paras;
+         procedure gen_vmt_entry_load; override;
         public
          function pass_typecheck: tnode; override;
          function pass_1: tnode; override;
@@ -492,6 +493,12 @@ implementation
     end;
 
 
+  procedure tjvmcallnode.gen_vmt_entry_load;
+    begin
+      { nothing to do }
+    end;
+
+
   function tjvmcallnode.pass_typecheck: tnode;
     begin
       result:=inherited pass_typecheck;

compiler/ncal.pas

@@ -84,6 +84,7 @@ interface
           procedure register_created_object_types;
           function get_expect_loc: tcgloc;
        protected
+          procedure gen_vmt_entry_load; virtual;
           procedure gen_syscall_para(para: tcallparanode); virtual;
           procedure objc_convert_to_message_send;virtual;
 
@@ -123,6 +124,8 @@ interface
           procdefinitionderef : tderef;
           { tree that contains the pointer to the object for this method }
           methodpointer  : tnode;
+          { tree representing the VMT entry to call (if any) }
+          vmt_entry      : tnode;
           { tree that contains the self/vmt parameter when this node was created
             (so it's still valid when this node is processed in an inline
              context)
@@ -1484,6 +1487,7 @@ implementation
            varargsparas.free;
          call_self_node.free;
          call_vmt_node.free;
+         vmt_entry.free;
 {$ifndef symansistr}
          stringdispose(fforcedprocname);
 {$endif symansistr}
@@ -2323,6 +2327,36 @@ implementation
       end;
 
 
+    procedure tcallnode.gen_vmt_entry_load;
+      var
+        vmt_def: trecorddef;
+      begin
+        if not assigned(right) and
+           (forcedprocname='') and
+           (po_virtualmethod in procdefinition.procoptions) and
+           not is_objectpascal_helper(tprocdef(procdefinition).struct) and
+           assigned(methodpointer) and
+           (methodpointer.nodetype<>typen) then
+          begin
+            vmt_entry:=load_vmt_for_self_node(methodpointer.getcopy);
+            { get the right entry in the VMT }
+            vmt_entry:=cderefnode.create(vmt_entry);
+            typecheckpass(vmt_entry);
+            vmt_def:=trecorddef(vmt_entry.resultdef);
+            { tobjectdef(tprocdef(procdefinition).struct) can be a parent of the
+              methodpointer's resultdef, but the vmtmethodoffset of the method
+              in that objectdef is obviously the same as in any child class }
+            vmt_entry:=csubscriptnode.create(
+                trecordsymtable(vmt_def.symtable).findfieldbyoffset(
+                  tobjectdef(tprocdef(procdefinition).struct).vmtmethodoffset(tprocdef(procdefinition).extnumber)
+                ),
+               vmt_entry
+              );
+            firstpass(vmt_entry);
+          end;
+      end;
+
+
     procedure tcallnode.gen_syscall_para(para: tcallparanode);
       begin
         { unsupported }
@@ -4093,6 +4127,9 @@ implementation
            end
          else
            expectloc:=LOC_VOID;
+
+         { create tree for VMT entry if required }
+         gen_vmt_entry_load;
       end;
 
 {$ifdef state_tracking}

compiler/ncgcal.pas

@@ -890,8 +890,7 @@ implementation
         href : treference;
         pop_size : longint;
         vmtoffset : aint;
-        pvreg,
-        vmtreg : tregister;
+        pvreg : tregister;
         oldaktcallnode : tcallnode;
         retlocitem: pcgparalocation;
         pd : tprocdef;
@@ -1001,37 +1000,26 @@ implementation
                  if tprocdef(procdefinition).extnumber=$ffff then
                    internalerror(200304021);
 
-                 secondpass(methodpointer);
+                 { load the VMT entry (address of the virtual method) }
+                 secondpass(vmt_entry);
 
-                 { Load VMT from self }
-                 if methodpointer.resultdef.typ=objectdef then
-                   gen_load_vmt_register(current_asmdata.CurrAsmList,tobjectdef(methodpointer.resultdef),methodpointer.location,vmtreg)
-                 else
-                   begin
-                     { Load VMT value in register }
-                     hlcg.location_force_reg(current_asmdata.CurrAsmList,methodpointer.location,methodpointer.resultdef,methodpointer.resultdef,false);
-                     vmtreg:=methodpointer.location.register;
-                     { test validity of VMT }
-                     if not(is_interface(tprocdef(procdefinition).struct)) and
-                        not(is_cppclass(tprocdef(procdefinition).struct)) then
-                       cg.g_maybe_testvmt(current_asmdata.CurrAsmList,vmtreg,tobjectdef(tprocdef(procdefinition).struct));
-                   end;
-
-                 { Call through VMT, generate a VTREF symbol to notify the linker }
-                 vmtoffset:=tobjectdef(tprocdef(procdefinition).struct).vmtmethodoffset(tprocdef(procdefinition).extnumber);
                  { register call for WPO }
                  if (not assigned(current_procinfo) or
                      wpoinfomanager.symbol_live(current_procinfo.procdef.mangledname)) then
                    tobjectdef(tprocdef(procdefinition).struct).register_vmt_call(tprocdef(procdefinition).extnumber);
 
-                 reference_reset_base(href,vmtreg,vmtoffset,proc_addr_voidptrdef.alignment);
+                 if not(vmt_entry.location.loc in [LOC_REFERENCE,LOC_CREFERENCE]) then
+                   internalerror(2015052502);
+                 href:=vmt_entry.location.reference;
                  pvreg:=NR_NO;
 
                  callref:=can_call_ref(href);
                  if not callref then
                    begin
                      pvreg:=get_call_reg(current_asmdata.CurrAsmList);
-                     cg.a_load_ref_reg(current_asmdata.CurrAsmList,proc_addr_size,proc_addr_size,href,pvreg);
+                     hlcg.a_load_ref_reg(current_asmdata.CurrAsmList,
+                       vmt_entry.resultdef,vmt_entry.resultdef,
+                       href,pvreg);
                    end;
 
                  { Load parameters that are in temporary registers in the

compiler/ncgmem.pas

@@ -138,11 +138,8 @@ implementation
                end;
            end
          else
-           begin
-             { left contains self, load vmt from self }
-             secondpass(left);
-             gen_load_vmt_register(current_asmdata.CurrAsmList,tobjectdef(left.resultdef),left.location,location.register);
-           end;
+           { should be handled in pass 1 }
+           internalerror(2015052801);
       end;
 
 

compiler/ncgutil.pas

@@ -85,7 +85,6 @@ interface
     procedure gen_load_para_value(list:TAsmList);
 
     procedure gen_external_stub(list:TAsmList;pd:tprocdef;const externalname:string);
-    procedure gen_load_vmt_register(list:TAsmList;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
 
     procedure get_used_regvars(n: tnode; var rv: tusedregvars);
     { adds the regvars used in n and its children to rv.allregvars,
@@ -1899,73 +1898,6 @@ implementation
       end;
 
 
-    procedure gen_load_vmt_register(list:TAsmList;objdef:tobjectdef;selfloc:tlocation;var vmtreg:tregister);
-      var
-        href : treference;
-        selfdef: tdef;
-      begin
-        if is_object(objdef) then
-          begin
-            case selfloc.loc of
-              LOC_CREFERENCE,
-              LOC_REFERENCE:
-                begin
-                  hlcg.reference_reset_base(href,voidpointertype,hlcg.getaddressregister(list,voidpointertype),objdef.vmt_offset,voidpointertype.size);
-                  hlcg.a_loadaddr_ref_reg(list,voidpointertype,voidpointertype,selfloc.reference,href.base);
-                  selfdef:=getpointerdef(objdef);
-                end;
-              else
-                internalerror(200305056);
-            end;
-          end
-        else
-          { This is also valid for Objective-C classes: vmt_offset is 0 there,
-            and the first "field" of an Objective-C class instance is a pointer
-            to its "meta-class".  }
-          begin
-            selfdef:=objdef;
-            case selfloc.loc of
-              LOC_REGISTER:
-                begin
-{$ifdef cpu_uses_separate_address_registers}
-                  if getregtype(selfloc.register)<>R_ADDRESSREGISTER then
-                    begin
-                      reference_reset_base(href,cg.getaddressregister(list),objdef.vmt_offset,sizeof(pint));
-                      cg.a_load_reg_reg(list,OS_ADDR,OS_ADDR,selfloc.register,href.base);
-                    end
-                  else
-{$endif cpu_uses_separate_address_registers}
-                    hlcg.reference_reset_base(href,voidpointertype,selfloc.register,objdef.vmt_offset,voidpointertype.size);
-                end;
-              LOC_CONSTANT,
-              LOC_CREGISTER,
-              LOC_CREFERENCE,
-              LOC_REFERENCE,
-              LOC_CSUBSETREG,
-              LOC_SUBSETREG,
-              LOC_CSUBSETREF,
-              LOC_SUBSETREF:
-                begin
-                  hlcg.reference_reset_base(href,voidpointertype,hlcg.getaddressregister(list,voidpointertype),objdef.vmt_offset,voidpointertype.size);
-                  { todo: pass actual vmt pointer type to hlcg }
-                  hlcg.a_load_loc_reg(list,voidpointertype,voidpointertype,selfloc,href.base);
-                end;
-              else
-                internalerror(200305057);
-            end;
-          end;
-        vmtreg:=hlcg.getaddressregister(list,voidpointertype);
-        hlcg.g_maybe_testself(list,selfdef,href.base);
-        hlcg.a_load_ref_reg(list,voidpointertype,voidpointertype,href,vmtreg);
-
-        { test validity of VMT }
-        if not(is_interface(objdef)) and
-           not(is_cppclass(objdef)) and
-           not(is_objc_class_or_protocol(objdef)) then
-           cg.g_maybe_testvmt(list,vmtreg,objdef);
-      end;
-
-
     function getprocalign : shortint;
       begin
         { gprof uses 16 byte granularity }

compiler/ncgvmt.pas

@@ -1086,7 +1086,9 @@ implementation
               genintmsgtab(tcb,intmessagetable,intmessagetabledef);
           end;
 
-         tcb.begin_anonymous_record('',voidpointertype.alignment,
+         { reuse the type created in nobj, so we get internal consistency
+           checking for free }
+         tcb.begin_anonymous_record('$vmtdef$'+_class.mangledparaname,voidpointertype.alignment,
            targetinfos[target_info.system]^.alignment.recordalignmin,
            targetinfos[target_info.system]^.alignment.maxCrecordalign);
 

compiler/nmem.pas

@@ -260,11 +260,11 @@ implementation
                    end
                  else
                    result:=objcloadbasefield(left,'ISA');
-                 { reused }
-                 left:=nil;
                end
              else
-               firstpass(left);
+               result:=ctypeconvnode.create_internal(load_vmt_for_self_node(left),resultdef);
+             { reused }
+             left:=nil;
            end
          else if not is_objcclass(left.resultdef) and
                  not is_objcclassref(left.resultdef) then

compiler/nobj.pas

@@ -46,6 +46,7 @@ interface
         procedure prot_get_procdefs_recursive(ImplProt:TImplementedInterface;ProtDef:TObjectDef);
         procedure intf_optimize_vtbls;
         procedure intf_allocate_vtbls;
+        procedure generate_vmt_def;
       public
         constructor create(c:tobjectdef);
         procedure  generate_vmt;
@@ -57,9 +58,9 @@ implementation
 
     uses
        SysUtils,
-       globals,verbose,systems,
+       globals,verbose,systems,fmodule,
        node,
-       symbase,symtable,symconst,symtype,defcmp,
+       symbase,symtable,symconst,symtype,defcmp,defutil,
        symcpu,
        dbgbase,
        wpobase
@@ -786,6 +787,90 @@ implementation
       end;
 
 
+    procedure TVMTBuilder.generate_vmt_def;
+      var
+        i: longint;
+        vmtdef: trecorddef;
+        systemvmt: tdef;
+        sym: tsym;
+        symtab: tsymtable;
+      begin
+        { these types don't have an actual VMT, we only use the other methods
+          in TVMTBuilder to determine duplicates/overrides }
+        if _class.objecttype in [
+           odt_helper,
+           odt_objcclass,
+           odt_objccategory,
+           odt_objcprotocol,
+           odt_javaclass,
+           odt_interfacecom_property,
+           odt_interfacecom_function,
+           odt_interfacejava] then
+         exit;
+
+        { todo in the future }
+        if _class.objecttype = odt_cppclass then
+          exit;
+
+        { the VMT definition may already exist in case of generics }
+        if searchsym_in_module(current_module,'vmtdef$'+_class.mangledparaname,sym,symtab) then
+          exit;
+        { create VMT type definition }
+        vmtdef:=crecorddef.create_global_internal(
+          '$vmtdef$'+_class.mangledparaname,
+          0,
+          target_info.alignment.recordalignmin,
+          target_info.alignment.maxCrecordalign);
+        { standard VMT fields }
+        case _Class.objecttype of
+          odt_class:
+            begin
+              systemvmt:=search_system_type('TVMT').typedef;
+              { does the TVMT type look like we expect? (so that this code is
+                easily triggered in case the definition of the VMT would
+                change) }
+              if (systemvmt.typ<>recorddef) or
+                 (trecorddef(systemvmt).symtable.SymList.count<>25) then
+                internalerror(2015052601);
+              { system.tvmt is a record that represents the VMT of TObject,
+                including its virtual methods. We only want the non-method
+                fields, as the methods will be added automatically based on
+                the VMT we generated here only add the 12 first fields }
+              for i:=0 to 11 do
+                begin
+                  sym:=tsym(trecorddef(systemvmt).symtable.SymList[i]);
+                  if sym.typ<>fieldvarsym then
+                    internalerror(2015052602);
+                  vmtdef.add_field_by_def(tfieldvarsym(sym).vardef);
+                end;
+            end;
+           odt_interfacecom,odt_interfacecorba,odt_dispinterface:
+             { nothing }
+             ;
+          odt_object:
+            begin
+              { size, -size, parent vmt [, dmt ] }
+              vmtdef.add_field_by_def(ptrsinttype);
+              vmtdef.add_field_by_def(ptrsinttype);
+              vmtdef.add_field_by_def(voidpointertype);
+{$ifdef WITHDMT}
+              vmtdef.add_field_by_def(voidpointertype);
+{$endif WITHDMT}
+            end;
+          else
+            internalerror(2015052605);
+        end;
+
+        { now add the methods }
+        for i:=0 to _class.vmtentries.count-1 do
+          vmtdef.add_field_by_def(
+            getprocaddressprocvar(pvmtentry(_class.vmtentries[i])^.procdef)
+          );
+        { the VMT ends with a nil pointer }
+        vmtdef.add_field_by_def(voidcodepointertype);
+      end;
+
+
     procedure TVMTBuilder.generate_vmt;
       var
         i : longint;
@@ -829,7 +914,7 @@ implementation
             { Allocate interface tables }
             intf_allocate_vtbls;
           end;
-
+        generate_vmt_def;
         current_structdef:=old_current_structdef;
       end;
 

compiler/nutils.pas

@@ -76,6 +76,9 @@ interface
     function load_self_pointer_node:tnode;
     function load_vmt_pointer_node:tnode;
     function is_self_node(p:tnode):boolean;
+    { create a tree that loads the VMT based on a self-node of an object/class/
+      interface }
+    function load_vmt_for_self_node(self_node: tnode): tnode;
 
     function node_complexity(p: tnode): cardinal;
     function node_resources_fpu(p: tnode): cardinal;
@@ -150,7 +153,7 @@ implementation
     uses
       cutils,verbose,globals,
       symconst,symdef,
-      defutil,defcmp,
+      defutil,defcmp,htypechk,
       nbas,ncon,ncnv,nld,nflw,nset,ncal,nadd,nmem,ninl,
       cpubase,cgbase,procinfo,
       pass_1;
@@ -554,6 +557,123 @@ implementation
       end;
 
 
+    function load_vmt_for_self_node(self_node: tnode): tnode;
+      var
+        self_resultdef: tdef;
+        obj_def: tobjectdef;
+        self_temp,
+        vmt_temp: ttempcreatenode;
+        check_self: tnode;
+        stat: tstatementnode;
+        block: tblocknode;
+        paras: tcallparanode;
+        docheck: boolean;
+      begin
+        self_resultdef:=self_node.resultdef;
+        case self_resultdef.typ of
+          classrefdef:
+            obj_def:=tobjectdef(tclassrefdef(self_resultdef).pointeddef);
+          objectdef:
+            obj_def:=tobjectdef(self_resultdef);
+          else
+            internalerror(2015052701);
+        end;
+        if is_classhelper(obj_def) then
+          obj_def:=tobjectdef(tobjectdef(obj_def).extendeddef);
+        docheck:=
+          not(is_interface(obj_def)) and
+          not(is_cppclass(obj_def)) and
+          not(is_objc_class_or_protocol(obj_def)) and
+          (([cs_check_object,cs_check_range]*current_settings.localswitches)<>[]);
+
+        block:=nil;
+        stat:=nil;
+        if docheck then
+          begin
+            { check for nil self-pointer }
+            block:=internalstatements(stat);
+            self_temp:=ctempcreatenode.create_value(
+              self_resultdef,self_resultdef.size,tt_persistent,true,
+              self_node);
+            addstatement(stat,self_temp);
+
+            { in case of an object, self can only be nil if it's a dereferenced
+              node somehow
+            }
+            if not is_object(self_resultdef) or
+               (actualtargetnode(@self_node)^.nodetype=derefn) then
+              begin
+                check_self:=ctemprefnode.create(self_temp);
+                if is_object(self_resultdef) then
+                  check_self:=caddrnode.create(check_self);
+                addstatement(stat,cifnode.create(
+                  caddnode.create(equaln,
+                    ctypeconvnode.create_explicit(
+                      check_self,
+                      voidpointertype
+                    ),
+                    cnilnode.create),
+                  ccallnode.createintern('fpc_objecterror',nil),
+                  nil)
+                );
+              end;
+            addstatement(stat,ctempdeletenode.create_normal_temp(self_temp));
+            self_node:=ctemprefnode.create(self_temp);
+          end;
+        { get the VMT field in case of a class/object }
+        if (self_resultdef.typ=objectdef) and
+           assigned(tobjectdef(self_resultdef).vmt_field) then
+          result:=csubscriptnode.create(tobjectdef(self_resultdef).vmt_field,self_node)
+        { in case of a classref, the "instance" is a pointer
+          to pointer to a VMT and there is no vmt field }
+        else if self_resultdef.typ=classrefdef then
+          result:=self_node
+        { in case of an interface, the "instance" is a pointer to a pointer
+          to a VMT -> dereference once already }
+        else
+          { in case of an interface/classref, the "instance" is a pointer
+            to pointer to a VMT and there is no vmt field }
+          result:=cderefnode.create(
+            ctypeconvnode.create_explicit(
+              self_node,
+              getpointerdef(voidpointertype)
+            )
+          );
+        result:=ctypeconvnode.create_explicit(
+          result,
+          getpointerdef(obj_def.vmt_def));
+        typecheckpass(result);
+        if docheck then
+          begin
+            { add a vmt validity check }
+            vmt_temp:=ctempcreatenode.create_value(result.resultdef,result.resultdef.size,tt_persistent,true,result);
+            addstatement(stat,vmt_temp);
+            paras:=ccallparanode.create(ctemprefnode.create(vmt_temp),nil);
+            if cs_check_object in current_settings.localswitches then
+              begin
+                paras:=ccallparanode.create(
+                  cloadvmtaddrnode.create(ctypenode.create(obj_def)),
+                  paras
+                );
+                addstatement(stat,
+                  ccallnode.createintern(
+                    'fpc_check_object_ext',paras
+                  )
+                );
+              end
+            else
+              addstatement(stat,
+                ccallnode.createintern(
+                  'fpc_check_object',paras
+                )
+              );
+            addstatement(stat,ctempdeletenode.create_normal_temp(vmt_temp));
+            addstatement(stat,ctemprefnode.create(vmt_temp));
+            result:=block;
+          end
+      end;
+
+
     { this function must return a very high value ("infinity") for   }
     { trees containing a call, the rest can be balanced more or less }
     { at will, probably best mainly in terms of required memory      }

compiler/symdef.pas

@@ -430,6 +430,7 @@ interface
           function  needs_separate_initrtti : boolean;override;
           function  rtti_mangledname(rt:trttitype):string;override;
           function  vmt_mangledname : TSymStr;
+          function  vmt_def: trecorddef;
           procedure check_forwards; override;
           procedure insertvmt;
           function  vmt_offset: asizeint;
@@ -6644,6 +6645,19 @@ implementation
       end;
 
 
+    function tobjectdef.vmt_def: trecorddef;
+      var
+        vmttypesym: tsym;
+      begin
+        vmttypesym:=tsym(get_top_level_symtable.Find('vmtdef$'+mangledparaname));
+        if not assigned(vmttypesym) or
+           (vmttypesym.typ<>symconst.typesym) or
+           (ttypesym(vmttypesym).typedef.typ<>recorddef) then
+          internalerror(2015052501);
+        result:=trecorddef(ttypesym(vmttypesym).typedef);
+      end;
+
+
     function tobjectdef.needs_inittable : boolean;
       var
         hp : tobjectdef;

compiler/symtype.pas

@@ -89,6 +89,7 @@ interface
          function  needs_separate_initrtti:boolean;virtual;abstract;
          procedure ChangeOwner(st:TSymtable);
          procedure register_created_object_type;virtual;
+         function  get_top_level_symtable: tsymtable;
       end;
 
 {************************************************
@@ -356,6 +357,15 @@ implementation
       begin
       end;
 
+
+    function tdef.get_top_level_symtable: tsymtable;
+      begin
+        result:=owner;
+        while assigned(result) and
+              assigned(result.defowner) do
+          result:=tdef(result.defowner).owner;
+      end;
+
 {****************************************************************************
                           TSYM (base for all symtypes)
 ****************************************************************************}

rtl/inc/compproc.inc

@@ -711,6 +711,7 @@ procedure fpc_largeset_comp_sets(set1,set2 : pointer;size : longint); compilerpr
 procedure fpc_largeset_contains_sets(set1,set2 : pointer; size: longint); compilerproc;
 {$endif LARGESETS}
 
+procedure fpc_objecterror; compilerproc;
 procedure fpc_rangeerror; compilerproc;
 procedure fpc_divbyzero; compilerproc;
 procedure fpc_overflow; compilerproc;

rtl/inc/system.inc

@@ -736,6 +736,10 @@ begin
 end;
 {$endif ndef FPC_SYSTEM_HAS_GET_CALLER_STACKINFO}
 
+procedure fpc_objecterror; compilerproc;
+begin
+  HandleErrorAddrFrameInd(210,get_pc_addr,get_frame);
+end;
 
 procedure fpc_rangeerror;[public,alias:'FPC_RANGEERROR']; compilerproc;
 begin