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

* if a generic parameter is local to the current procdef then use the local symtable for the specialization
+ added test

Sven/Sarah Barth 1 долоо хоног өмнө
parent
commit
6fe10aafff

+ 25 - 4
compiler/pgenutil.pas

@@ -1897,10 +1897,31 @@ uses
               end;
           end
         else
-          if current_module.is_unit and current_module.in_interface then
-            specializest:=current_module.globalsymtable
-          else
-            specializest:=current_module.localsymtable;
+          begin
+            { if one of the type parameters is owned by a local- or parasymtable
+              then use the localsymtable for specialization }
+            specializest:=nil;
+            for i:=0 to context.paramlist.count-1 do
+              begin
+                psym:=tsym(context.paramlist[i]);
+                if psym.owner.symtabletype in [localsymtable,parasymtable] then
+                  begin
+                    if (psym.owner.symtabletype=localsymtable) or (psym.owner.defowner.typ<>procdef) then
+                      specializest:=psym.owner
+                    else
+                      specializest:=tprocdef(psym.owner.defowner).getsymtable(gs_local);
+                    if not assigned(specializest) then
+                      internalerror(2025122402);
+                    break;
+                  end;
+              end;
+
+            if not assigned(specializest) then
+              if current_module.is_unit and current_module.in_interface then
+                specializest:=current_module.globalsymtable
+              else
+                specializest:=current_module.localsymtable;
+          end;
         if not assigned(specializest) then
           internalerror(2014050910);
 

+ 11 - 0
tests/tbs/tb0725.pp

@@ -0,0 +1,11 @@
+{ %RECOMPILE }
+{ %NORUN }
+
+program tb0725;
+
+uses
+  ub0725;
+
+begin
+
+end.

+ 41 - 0
tests/tbs/tb0726.pp

@@ -0,0 +1,41 @@
+{ %NORUN }
+
+program tb0726;
+
+{$mode objfpc}{$H+}
+
+type
+  generic TTest1<T> = class
+    procedure Test;
+  end;
+
+  generic TTest2<T> = class
+    procedure Test;
+  end;
+
+procedure TTest1.Test;
+begin
+end;
+
+procedure Test;
+type
+  TArr = packed array [0..1] of Single;
+  TTest1Arr = specialize TTest1<TArr>;
+  TTest2Arr = specialize TTest2<TArr>;
+var
+  a: TTest1Arr;
+  b: TTest2Arr;
+begin
+  a := TTest1Arr.Create;
+  a.Free;
+  b := TTest2Arr.Create;
+  b.Free;
+end;
+
+procedure TTest2.Test;
+begin
+end;
+
+begin
+
+end.

+ 39 - 0
tests/tbs/ub0725.pp

@@ -0,0 +1,39 @@
+unit ub0725;
+
+{$mode objfpc}{$H+}
+{$modeswitch advancedrecords}
+
+interface
+
+type
+  TValue = record
+    f: Pointer;
+    generic class function From<T>(constref aValue: T): TValue; static;
+  end;
+
+procedure Test;
+
+implementation
+
+var
+  { trigger creation of init and fini procs }
+  s: String = 'Hello World';
+
+generic class function TValue.From<T>(constref aValue: T): TValue;
+begin
+  Result.f := TypeInfo(T);
+end;
+
+procedure Test;
+type
+  TArr = array[0..0] of LongInt;
+var
+  v: TValue;
+  arr: TArr;
+begin
+  arr[0] := 42;
+  v := TValue.specialize From<TArr>(arr);
+end;
+
+end.
+