2
0
Эх сурвалжийг харах

Fix for bug report 41443:

Also register procsym of procedure definition if assigned

Add explicit error for unregistered definition or symbol,
for which registering should have been done.

Add tw41443.pp and unit files uw41443*.pp to check bug fix.
Pierre Muller 5 өдөр өмнө
parent
commit
ce8a4b2fc0

+ 3 - 0
compiler/ncal.pas

@@ -4266,6 +4266,9 @@ implementation
                    { if the final procedure definition is not yet owned,
                      ensure that it is }
                    procdefinition.register_def;
+                   if (procdefinition.typ=procdef) and assigned(tprocdef(procdefinition).procsym) then
+                     tprocdef(procdefinition).procsym.register_sym;
+
                    if procdefinition.is_specialization and (procdefinition.typ=procdef) then
                      maybe_add_pending_specialization(procdefinition,candidates.para_anon_syms);
 

+ 17 - 4
compiler/symdef.pas

@@ -2675,11 +2675,24 @@ implementation
      var
        gst : tgetsymtable;
        st : tsymtable;
+       tmod : tmodule;
      begin
        if registered then
          exit;
+       if assigned(owner) then
+         begin
+           tmod:=find_module_from_symtable(owner);
+            if assigned(tmod) and assigned(current_module) and (tmod<>current_module) then
+              begin
+                comment(v_error,'Definition '+fullownerhierarchyname(false)+' from module '+tmod.mainsource+' regitered with current module '+current_module.mainsource);
+              end;
+           if not assigned(tmod) then
+             tmod:=current_module;
+         end
+       else
+         tmod:=current_module;
        { Register in current_module }
-       if assigned(current_module) then
+       if assigned(tmod) then
          begin
            exclude(defoptions,df_not_registered_no_free);
            for gst:=low(tgetsymtable) to high(tgetsymtable) do
@@ -2692,9 +2705,9 @@ implementation
              defid:=deflist_index
            else
              begin
-               current_module.deflist.Add(self);
-               defid:=current_module.deflist.Count-1;
-               registered_in_module:=current_module;
+               tmod.deflist.Add(self);
+               defid:=tmod.deflist.Count-1;
+               registered_in_module:=tmod;
              end;
            maybe_put_in_symtable_stack;
          end

+ 17 - 3
compiler/symsym.pas

@@ -738,14 +738,28 @@ implementation
 
 
     procedure tstoredsym.register_sym;
+      var
+        tmod : tmodule;
       begin
         if registered then
           exit;
+        if assigned(owner) then
+          begin
+            tmod:=find_module_from_symtable(owner);
+            if assigned(tmod) and assigned(current_module) and (tmod<>current_module) then
+              begin
+                comment(v_error,'Symbol '+realname+' from module '+tmod.mainsource+' regitered with current module '+current_module.mainsource);
+              end;
+	    if not assigned(tmod) then
+              tmod:=current_module;
+          end
+	else
+          tmod:=current_module;
         { Register in current_module }
-        if assigned(current_module) then
+        if assigned(tmod) then
           begin
-            current_module.symlist.Add(self);
-            SymId:=current_module.symlist.Count-1;
+            tmod.symlist.Add(self);
+            SymId:=tmod.symlist.Count-1;
           end
         else
           SymId:=symid_registered_nost;

+ 10 - 0
tests/webtbs/tw41443.pp

@@ -0,0 +1,10 @@
+{%RECOMPILE}
+
+program kek;
+{$mode objfpc}
+
+uses
+  uw41443a;
+
+begin
+end.

+ 29 - 0
tests/webtbs/uw41443a.pp

@@ -0,0 +1,29 @@
+unit uw41443a;
+{$mode objfpc}
+
+interface
+
+uses
+  uw41443b;
+
+procedure uw41443a_proc2;
+
+implementation
+
+type
+  tdummy_uw41443a = -1..7;
+
+const
+  uw41443a_counter : tdummy_uw41443a = 0;
+
+procedure uw41443a_proc1;{$ifndef DISABLE_PROC1_INLINE} inline;{$endif}
+begin
+  inc(uw41443a_counter);
+end;
+
+procedure uw41443a_proc2; inline;
+begin
+  uw41443a_proc1;
+end;
+
+end.

+ 21 - 0
tests/webtbs/uw41443b.pp

@@ -0,0 +1,21 @@
+unit uw41443b;
+{$mode objfpc}
+
+interface
+
+uses
+  uw41443c;
+
+procedure uw41443b_proc3;
+
+implementation
+
+uses
+  uw41443a;
+
+procedure uw41443b_proc3;
+begin
+  uw41443a_proc2;
+end;
+
+end.

+ 18 - 0
tests/webtbs/uw41443c.pp

@@ -0,0 +1,18 @@
+unit uw41443c;
+{$mode objfpc}
+
+interface
+
+procedure uw41443c_proc4;
+
+implementation
+
+uses
+  uw41443b;
+
+procedure uw41443c_proc4;
+begin
+  uw41443b_proc3;
+end;
+
+end.