From 3e7dc25667435fb50f3e6f860f95b99b6d24dfe0 Mon Sep 17 00:00:00 2001 From: svenbarth Date: Mon, 30 Dec 2019 21:35:26 +0000 Subject: [PATCH] * fix for Mantis #36496: correctly handle the function result alias variable inside generic functions + added tests git-svn-id: trunk@43823 - --- .gitattributes | 4 ++++ compiler/pgenutil.pas | 23 +++++++++++++++++++++++ tests/tbs/tb0666a.pp | 22 ++++++++++++++++++++++ tests/tbs/tb0666b.pp | 22 ++++++++++++++++++++++ tests/webtbs/tw36496a.pp | 38 ++++++++++++++++++++++++++++++++++++++ tests/webtbs/tw36496b.pp | 38 ++++++++++++++++++++++++++++++++++++++ 6 files changed, 147 insertions(+) create mode 100644 tests/tbs/tb0666a.pp create mode 100644 tests/tbs/tb0666b.pp create mode 100644 tests/webtbs/tw36496a.pp create mode 100644 tests/webtbs/tw36496b.pp diff --git a/.gitattributes b/.gitattributes index a9e515adeb..2faacb3b79 100644 --- a/.gitattributes +++ b/.gitattributes @@ -12992,6 +12992,8 @@ tests/tbs/tb0662.pp svneol=native#text/pascal tests/tbs/tb0663.pp svneol=native#text/plain tests/tbs/tb0664.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/ub0060.pp svneol=native#text/plain tests/tbs/ub0069.pp svneol=native#text/plain tests/tbs/ub0119.pp svneol=native#text/plain @@ -17906,6 +17908,8 @@ 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/tw36389.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/tw3661.pp svneol=native#text/plain diff --git a/compiler/pgenutil.pas b/compiler/pgenutil.pas index 0312158b79..1069fb7c14 100644 --- a/compiler/pgenutil.pas +++ b/compiler/pgenutil.pas @@ -463,6 +463,7 @@ uses countstr,genname,ugenname : string; srsym : tsym; st : tsymtable; + tmpstack : tfpobjectlist; begin context:=nil; result:=nil; @@ -579,6 +580,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); 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/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. +