From fdb477df1e6caa3ee1219ab4266fe2f0c2d0eecf Mon Sep 17 00:00:00 2001 From: marco Date: Tue, 14 Jan 2020 10:41:39 +0000 Subject: [PATCH] # revisions: 43566,43567,43568,43586,43629,43823 git-svn-id: branches/fixes_3_2@43941 - --- .gitattributes | 8 ++++++ compiler/pgenutil.pas | 59 +++++++++++++++++++++++++++++++++++++--- compiler/symbase.pas | 4 +++ compiler/symtable.pas | 10 +++++++ tests/tbs/tb0665.pp | 33 ++++++++++++++++++++++ tests/tbs/tb0666a.pp | 22 +++++++++++++++ tests/tbs/tb0666b.pp | 22 +++++++++++++++ tests/test/tgenfunc19.pp | 33 ++++++++++++++++++++++ tests/test/ugenfunc19.pp | 37 +++++++++++++++++++++++++ tests/webtbs/tw36388.pp | 16 +++++++++++ tests/webtbs/tw36496a.pp | 38 ++++++++++++++++++++++++++ tests/webtbs/tw36496b.pp | 38 ++++++++++++++++++++++++++ 12 files changed, 316 insertions(+), 4 deletions(-) create mode 100644 tests/tbs/tb0665.pp create mode 100644 tests/tbs/tb0666a.pp create mode 100644 tests/tbs/tb0666b.pp create mode 100644 tests/test/tgenfunc19.pp create mode 100644 tests/test/ugenfunc19.pp create mode 100644 tests/webtbs/tw36388.pp create mode 100644 tests/webtbs/tw36496a.pp create mode 100644 tests/webtbs/tw36496b.pp diff --git a/.gitattributes b/.gitattributes index 308093feb5..a2e79235ac 100644 --- a/.gitattributes +++ b/.gitattributes @@ -11731,6 +11731,9 @@ tests/tbs/tb0654.pp svneol=native#text/plain tests/tbs/tb0655.pp svneol=native#text/pascal tests/tbs/tb0656.pp svneol=native#text/pascal tests/tbs/tb0657.pp svneol=native#text/pascal +tests/tbs/tb0665.pp svneol=native#text/pascal +tests/tbs/tb0666a.pp svneol=native#text/pascal +tests/tbs/tb0666b.pp svneol=native#text/pascal tests/tbs/tb205.pp svneol=native#text/plain tests/tbs/tb610.pp svneol=native#text/pascal tests/tbs/tb613.pp svneol=native#text/plain @@ -13326,6 +13329,7 @@ tests/test/tgenfunc15.pp svneol=native#text/pascal tests/test/tgenfunc16.pp svneol=native#text/pascal tests/test/tgenfunc17.pp svneol=native#text/pascal tests/test/tgenfunc18.pp svneol=native#text/pascal +tests/test/tgenfunc19.pp svneol=native#text/pascal tests/test/tgenfunc2.pp svneol=native#text/pascal tests/test/tgenfunc3.pp svneol=native#text/pascal tests/test/tgenfunc4.pp svneol=native#text/pascal @@ -14063,6 +14067,7 @@ tests/test/ugeneric96b.pp svneol=native#text/pascal tests/test/ugeneric96c.pp svneol=native#text/pascal tests/test/ugeneric96d.pp svneol=native#text/pascal tests/test/ugeneric99.pp svneol=native#text/pascal +tests/test/ugenfunc19.pp svneol=native#text/pascal tests/test/ugenfunc7.pp svneol=native#text/pascal tests/test/uhintdir.pp svneol=native#text/plain tests/test/uhlp3.pp svneol=native#text/pascal @@ -16484,6 +16489,9 @@ tests/webtbs/tw3619.pp svneol=native#text/plain tests/webtbs/tw3621.pp svneol=native#text/plain tests/webtbs/tw3628.pp svneol=native#text/plain tests/webtbs/tw3634.pp svneol=native#text/plain +tests/webtbs/tw36388.pp svneol=native#text/pascal +tests/webtbs/tw36496a.pp svneol=native#text/pascal +tests/webtbs/tw36496b.pp svneol=native#text/pascal tests/webtbs/tw3650.pp svneol=native#text/plain tests/webtbs/tw3653.pp svneol=native#text/plain tests/webtbs/tw36544a.pp svneol=native#text/pascal diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index 8280870812..3746e5872b 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -464,6 +464,7 @@ uses countstr,genname,ugenname : string; srsym : tsym; st : tsymtable; + tmpstack : tfpobjectlist; begin context:=nil; result:=nil; @@ -472,8 +473,21 @@ uses errorrecovery:=false; if (symname='') and (not assigned(genericdef) or - not assigned(genericdef.typesym) or - (genericdef.typesym.typ<>typesym)) then + ( + (genericdef.typ<>procdef) and + ( + not assigned(genericdef.typesym) or + (genericdef.typesym.typ<>typesym) + ) + ) or + ( + (genericdef.typ=procdef) and + ( + not assigned(tprocdef(genericdef).procsym) or + (tprocdef(genericdef).procsym.typ<>procsym) + ) + ) + ) then begin errorrecovery:=true; result:=generrordef; @@ -592,7 +606,12 @@ uses { use the name of the symbol as procvars return a user friendly version of the name } if symname='' then - genname:=ttypesym(genericdef.typesym).realname + begin + if genericdef.typ=procdef then + genname:=tprocdef(genericdef).procsym.realname + else + genname:=ttypesym(genericdef.typesym).realname; + end else genname:=symname; @@ -646,6 +665,28 @@ uses else found:=searchsym(ugenname,context.sym,context.symtable); + if found and (context.sym.typ=absolutevarsym) and + (vo_is_funcret in tabstractvarsym(context.sym).varoptions) then + begin + { we found the function result alias of a generic function; go up the + symbol stack *before* this alias was inserted, so that we can + (hopefully) find the correct generic symbol } + tmpstack:=tfpobjectlist.create(false); + while assigned(symtablestack.top) do + begin + tmpstack.Add(symtablestack.top); + symtablestack.pop(symtablestack.top); + if tmpstack.Last=context.symtable then + break; + end; + if not assigned(symtablestack.top) then + internalerror(2019123001); + found:=searchsym(ugenname,context.sym,context.symtable); + for i:=tmpstack.count-1 downto 0 do + symtablestack.push(tsymtable(tmpstack[i])); + tmpstack.free; + end; + if not found or not (context.sym.typ in [typesym,procsym]) then begin identifier_not_found(genname); @@ -735,6 +776,7 @@ uses old_current_specializedef, old_current_genericdef : tstoreddef; old_current_procinfo : tprocinfo; + old_module_procinfo : tobject; hmodule : tmodule; oldcurrent_filepos : tfileposinfo; recordbuf : tdynamicarray; @@ -859,7 +901,13 @@ uses { decide in which symtable to put the specialization } if parse_generic and not assigned(result) then begin - if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then + srsymtable:=symtablestack.top; + if (srsymtable.symtabletype in [localsymtable,parasymtable]) and tstoreddef(srsymtable.defowner).is_specialization then + { if we are currently specializing a routine we need to specialize into + the routine's local- or parasymtable so that they are correctly + registered should the specialization be finalized } + specializest:=srsymtable + else if assigned(current_procinfo) and (df_generic in current_procinfo.procdef.defoptions) then { if we are parsing the definition of a method we specialize into the local symtable of it } specializest:=current_procinfo.procdef.getsymtable(gs_local) @@ -943,8 +991,10 @@ uses old_current_genericdef:=nil; old_current_structdef:=nil; old_current_procinfo:=current_procinfo; + old_module_procinfo:=current_module.procinfo; current_procinfo:=nil; + current_module.procinfo:=nil; if parse_class_parent then begin @@ -1126,6 +1176,7 @@ uses block_type:=old_block_type; current_procinfo:=old_current_procinfo; + current_module.procinfo:=old_module_procinfo; if parse_class_parent then begin current_structdef:=old_current_structdef; diff --git a/compiler/symbase.pas b/compiler/symbase.pas index 29ae0d6df1..2b083afd19 100644 --- a/compiler/symbase.pas +++ b/compiler/symbase.pas @@ -283,6 +283,10 @@ implementation while assigned(st.defowner) do begin st:=st.defowner.owner; + { this can happen for specializations of routines that are not yet + owned cause they might be thrown away again } + if not assigned(st) then + break; { the flag is already set, so by definition it is set in the owning symtables as well } if option in st.tableoptions then diff --git a/compiler/symtable.pas b/compiler/symtable.pas index 5c38d5ef71..b4336175f9 100644 --- a/compiler/symtable.pas +++ b/compiler/symtable.pas @@ -4119,6 +4119,16 @@ implementation anything } if current_module.extendeddefs.count=0 then exit; + if (df_genconstraint in pd.defoptions) then + begin + { if we have a constraint for a class type or a single interface we + use that to resolve helpers at declaration time of the generic, + otherwise there can't be any helpers as the type isn't known yet } + if pd.typ=objectdef then + pd:=tobjectdef(pd).getparentdef + else + exit; + end; { no helpers for anonymous types } if ((pd.typ in [recorddef,objectdef]) and ( diff --git a/tests/tbs/tb0665.pp b/tests/tbs/tb0665.pp new file mode 100644 index 0000000000..4d268e7aee --- /dev/null +++ b/tests/tbs/tb0665.pp @@ -0,0 +1,33 @@ +program tb0665; + +{$mode objfpc} +{$modeswitch advancedrecords} + +type + TTest = record + b: Boolean; + function Test(aArg: Pointer): Boolean; inline; + generic function Test: Boolean; inline; + end; + +function TTest.Test(aArg: Pointer): Boolean; +begin + b := True; + Result := True; +end; + +generic function TTest.Test: Boolean; +begin + Result := Test(Nil); +end; + +var + t: TTest; +begin + t.b := False; + { check for side effects to ensure that the code was correctly generated } + t.specialize Test; + if not t.b then + Halt(1); + Writeln('ok'); +end. diff --git a/tests/tbs/tb0666a.pp b/tests/tbs/tb0666a.pp new file mode 100644 index 0000000000..50c34bce8a --- /dev/null +++ b/tests/tbs/tb0666a.pp @@ -0,0 +1,22 @@ +{ %NORUN } + +program tb0666a; + +{$mode delphi} + +function Test: T; + + procedure Foo; + begin + Test; + Test; + Test; + end; + +begin + Foo; +end; + +begin + Test; +end. diff --git a/tests/tbs/tb0666b.pp b/tests/tbs/tb0666b.pp new file mode 100644 index 0000000000..25eda37b3e --- /dev/null +++ b/tests/tbs/tb0666b.pp @@ -0,0 +1,22 @@ +{ %NORUN } + +program tb0666b; + +{$mode objfpc} + +generic function Test: T; + + procedure Foo; + begin + specialize Test; + specialize Test; + specialize Test; + end; + +begin + Foo; +end; + +begin + specialize Test; +end. diff --git a/tests/test/tgenfunc19.pp b/tests/test/tgenfunc19.pp new file mode 100644 index 0000000000..28a5307feb --- /dev/null +++ b/tests/test/tgenfunc19.pp @@ -0,0 +1,33 @@ +program tgenfunc19; + +{$mode objfpc} + +uses + ugenfunc19; + +type + TTest2 = class(TTest) + class function Test: LongInt; + end; + + TTest2Helper = class helper for TTest2 + class function Test: LongInt; + end; + +class function TTest2.Test: LongInt; +begin + Result := 3; +end; + +class function TTest2Helper.Test: LongInt; +begin + Result := 4; +end; + +begin + if specialize DoTest <> 2 then + Halt(1); + if specialize DoTest <> 3 then + Halt(2); + Writeln('Ok'); +end. diff --git a/tests/test/ugenfunc19.pp b/tests/test/ugenfunc19.pp new file mode 100644 index 0000000000..c9733260bd --- /dev/null +++ b/tests/test/ugenfunc19.pp @@ -0,0 +1,37 @@ +unit ugenfunc19; + +{$mode objfpc}{$H+} + +interface + +type + TTest = class + class function Test: LongInt; static; + end; + + TTestHelper = class helper for TTest + class function Test: LongInt; static; + end; + +generic function DoTest: LongInt; + +implementation + +class function TTest.Test: LongInt; +begin + Result := 1; +end; + +class function TTestHelper.Test: LongInt; +begin + Result := 2; +end; + +generic function DoTest: LongInt; +begin + Result := T.Test; +end; + + +end. + diff --git a/tests/webtbs/tw36388.pp b/tests/webtbs/tw36388.pp new file mode 100644 index 0000000000..7949e2bd95 --- /dev/null +++ b/tests/webtbs/tw36388.pp @@ -0,0 +1,16 @@ +{ %NORUN } + +{$mode objfpc} + +program tw36388; +uses + SysUtils, FGL; + +generic function CopyList (source: T): T; +begin + // Internal error 200204175 + result := T.Create; +end; + +begin +end. diff --git a/tests/webtbs/tw36496a.pp b/tests/webtbs/tw36496a.pp new file mode 100644 index 0000000000..d4bb5d0ac5 --- /dev/null +++ b/tests/webtbs/tw36496a.pp @@ -0,0 +1,38 @@ +{ %NORUN } + +(* + testing application for + https://forum.lazarus.freepascal.org/index.php/topic,47936.0.html +*) +program tw36496a; + +{$Mode delphi} + +function TestGenRecurse(const AInput : T) : Boolean; +begin + //Result := False; + + (* + below, if uncommented will fail to compile + tester.lpr(12,19) Error: Identifier not found "TestGenRecurse$1" + *) + TestGenRecurse(AInput); + TestGenRecurse('test'); + TestGenRecurse(42); +end; + +procedure TestGenRecurseProc(const AInput : T); +begin + (* + below method calls compile fine + *) + TestGenRecurseProc(AInput); + TestGenRecurseProc('test'); + TestGenRecurseProc(42); +end; + +begin + TestGenRecurse('testing'); + TestGenRecurseProc('testing'); +end. + diff --git a/tests/webtbs/tw36496b.pp b/tests/webtbs/tw36496b.pp new file mode 100644 index 0000000000..3a002a5e05 --- /dev/null +++ b/tests/webtbs/tw36496b.pp @@ -0,0 +1,38 @@ +{ %NORUN } + +(* + testing application for + https://forum.lazarus.freepascal.org/index.php/topic,47936.0.html +*) +program tw36496b; + +{$Mode objfpc}{$H+} + +generic function TestGenRecurse(const AInput : T) : Boolean; +begin + //Result := False; + + (* + below, if uncommented will fail to compile + tester.lpr(12,19) Error: Identifier not found "TestGenRecurse$1" + *) + specialize TestGenRecurse(AInput); + specialize TestGenRecurse('test'); + specialize TestGenRecurse(42); +end; + +generic procedure TestGenRecurseProc(const AInput : T); +begin + (* + below method calls compile fine + *) + specialize TestGenRecurseProc(AInput); + specialize TestGenRecurseProc('test'); + specialize TestGenRecurseProc(42); +end; + +begin + specialize TestGenRecurse('testing'); + specialize TestGenRecurseProc('testing'); +end. +