paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-04-20 11:29:27 +02:00
Code Issues Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/main' into wasm_js_promise_integration

Browse Source
This commit is contained in:
Nikolay Nikolov 2023-06-24 15:08:18 +03:00
commit adf843196a
11 changed files with 281 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
compiler/pdecl.pas
View File

@ -912,12 +912,15 @@ implementation
Delphi-compatible }
hdef2:=tstoreddef(hdef).getcopy;
tobjectdef(hdef2).childof:=tobjectdef(hdef);
tstoreddef(hdef2).orgdef:=tstoreddef(hdef);
hdef:=hdef2;
end
else
begin
hdef:=tstoreddef(hdef).getcopy;
{ check if it is an ansistirng(codepage) declaration }
hdef2:=tstoreddef(hdef).getcopy;
tstoreddef(hdef2).orgdef:=tstoreddef(hdef);
hdef:=hdef2;
{ check if it is an ansistring(codepage) declaration }
if is_ansistring(hdef) and try_to_consume(_LKLAMMER) then
begin
p:=comp_expr([ef_accept_equal]);

11
compiler/pdecobj.pas
View File

@ -730,11 +730,22 @@ implementation
end;
procedure check_inheritance_record_type_helper(var def:tdef);
var
tmp : tstoreddef;
begin
if (def.typ<>errordef) and assigned(current_objectdef.childof) then
begin
if def<>current_objectdef.childof.extendeddef then
begin
{ a type helper may extend a type alias of the type its
parent type helper extends }
tmp:=tstoreddef(def);
while (df_unique in tmp.defoptions) and assigned(tstoreddef(tmp).orgdef) do
begin
if tmp.orgdef=current_objectdef.childof.extendeddef then
exit;
tmp:=tstoreddef(tmp.orgdef);
end;
Message1(type_e_record_helper_must_extend_same_record,current_objectdef.childof.extendeddef.typename);
def:=generrordef;
end;

29
compiler/pdecsub.pas
View File

@ -545,6 +545,7 @@ implementation
found,
searchagain : boolean;
st,
insertst,
genericst: TSymtable;
aprocsym : tprocsym;
popclass : integer;
@ -854,19 +855,23 @@ implementation
hadspecialize:=false;
addgendummy:=false;
{ ensure that we don't insert into a withsymtable (can happen with
anonymous functions) }
checkstack:=symtablestack.stack;
while checkstack^.symtable.symtabletype in [withsymtable] do
checkstack:=checkstack^.next;
insertst:=checkstack^.symtable;
if not assigned(genericdef) then
begin
if ppf_anonymous in flags then
begin
checkstack:=symtablestack.stack;
while checkstack^.symtable.symtabletype in [withsymtable] do
checkstack:=checkstack^.next;
if not (checkstack^.symtable.symtabletype in [localsymtable,staticsymtable]) then
if not (insertst.symtabletype in [localsymtable,staticsymtable]) then
internalerror(2021050101);
{ generate a unique name for the anonymous function; don't use
something like file position however as this might be inside
an include file that's included multiple times }
str(checkstack^.symtable.symlist.count,orgsp);
str(insertst.symlist.count,orgsp);
orgsp:='__FPCINTERNAL__Anonymous_'+orgsp;
sp:=upper(orgsp);
spnongen:=sp;
@ -1032,7 +1037,7 @@ implementation
if (potype=potype_operator)and(optoken=NOTOKEN) then
parse_operator_name;
srsym:=tsym(symtablestack.top.Find(sp));
srsym:=tsym(insertst.Find(sp));
{ Also look in the globalsymtable if we didn't found
the symbol in the localsymtable }
@ -1102,7 +1107,7 @@ implementation
operation }
if (potype=potype_operator) then
begin
aprocsym:=Tprocsym(symtablestack.top.Find(sp));
aprocsym:=Tprocsym(insertst.Find(sp));
if aprocsym=nil then
aprocsym:=cprocsym.create('$'+sp);
end
@ -1115,7 +1120,7 @@ implementation
include(aprocsym.symoptions,sp_internal);
if addgendummy then
include(aprocsym.symoptions,sp_generic_dummy);
symtablestack.top.insertsym(aprocsym);
insertst.insertsym(aprocsym);
end;
end;
@ -1176,7 +1181,7 @@ implementation
dummysym:=tsym(astruct.symtable.find(spnongen))
else
begin
dummysym:=tsym(symtablestack.top.find(spnongen));
dummysym:=tsym(insertst.find(spnongen));
if not assigned(dummysym) and
(symtablestack.top=current_module.localsymtable) and
assigned(current_module.globalsymtable) then
@ -1190,7 +1195,7 @@ implementation
if assigned(astruct) then
astruct.symtable.insertsym(dummysym)
else
symtablestack.top.insertsym(dummysym);
insertst.insertsym(dummysym);
end
else if (dummysym.typ<>procsym) and
(
@ -1282,8 +1287,8 @@ implementation
{ symbol options that need to be kept per procdef }
pd.fileinfo:=procstartfilepos;
pd.visibility:=symtablestack.top.currentvisibility;
if symtablestack.top.currentlyoptional then
pd.visibility:=insertst.currentvisibility;
if insertst.currentlyoptional then
include(pd.procoptions,po_optional);
{ parse parameters }

9
compiler/pparautl.pas
View File

@ -357,8 +357,13 @@ implementation
{ insert the name of the procedure as alias for the function result,
we can't use realname because that will not work for compilerprocs
as the name is lowercase and unreachable from the code }
if (pd.proctypeoption<>potype_operator) or assigned(pd.resultname) then
as the name is lowercase and unreachable from the code;
don't insert this alias for an anonymous function unless an
explicit name is provided }
if (
(pd.proctypeoption<>potype_operator) and
not (po_anonymous in pd.procoptions)
) or assigned(pd.resultname) then
begin
if assigned(pd.resultname) then
hs:=pd.resultname^

10
compiler/symdef.pas
View File

@ -138,6 +138,9 @@ interface
genconstraintdata : tgenericconstraintdata;
{ this is Nil if the def has no RTTI attributes }
rtti_attribute_list : trtti_attribute_list;
{ original def for "type <name>" declarations }
orgdef : tstoreddef;
orgdefderef : tderef;
constructor create(dt:tdeftyp;doregister:boolean);
constructor ppuload(dt:tdeftyp;ppufile:tcompilerppufile);
destructor destroy;override;
@ -2103,6 +2106,8 @@ implementation
ppufile.getderef(typesymderef);
ppufile.getset(tppuset2(defoptions));
ppufile.getset(tppuset1(defstates));
if df_unique in defoptions then
ppufile.getderef(orgdefderef);
if df_genconstraint in defoptions then
begin
genconstraintdata:=tgenericconstraintdata.create;
@ -2273,6 +2278,8 @@ implementation
oldintfcrc:=ppufile.do_crc;
ppufile.do_crc:=false;
ppufile.putset(tppuset1(defstates));
if df_unique in defoptions then
ppufile.putderef(orgdefderef);
if df_genconstraint in defoptions then
genconstraintdata.ppuwrite(ppufile);
if [df_generic,df_specialization]*defoptions<>[] then
@ -2340,6 +2347,7 @@ implementation
if not registered then
register_def;
typesymderef.build(typesym);
orgdefderef.build(orgdef);
genericdefderef.build(genericdef);
if assigned(rtti_attribute_list) then
rtti_attribute_list.buildderef;
@ -2371,6 +2379,8 @@ implementation
i : longint;
begin
typesym:=ttypesym(typesymderef.resolve);
if df_unique in defoptions then
orgdef:=tstoreddef(orgdefderef.resolve);
if df_specialization in defoptions then
genericdef:=tstoreddef(genericdefderef.resolve);
if assigned(rtti_attribute_list) then

6
compiler/utils/ppuutils/ppudump.pp
View File

@ -2872,6 +2872,12 @@ begin
end;
writeln;
if df_unique in defoptions then
begin
write ([space,' OriginalDef : ']);
readderef(space);
end;
if df_genconstraint in defoptions then
begin
ppufile.getset(tppuset1(genconstr));

35
tests/test/tanonfunc73.pp Normal file
View File

@ -0,0 +1,35 @@
{ %NORUN }
program tanonfunc73;
{$mode objfpc}
{$modeswitch anonymousfunctions}
{$modeswitch functionreferences}
type
TProc = reference to procedure;
procedure Test;
var
o: TObject;
p: TProc;
begin
with o do begin
p := procedure
begin
Writeln('Hello World');
end;
end;
end;
var
o: TObject;
p: TProc;
begin
with o do begin
p := procedure
begin
Writeln('Hello World');
end;
end;
end.

72
tests/test/tthlp30.pp Normal file
View File

@ -0,0 +1,72 @@
program tthlp30;
{$mode objfpc}
{$modeswitch typehelpers}
type
Test1 = type LongInt;
Test2 = type LongInt;
Test3 = type Test1;
TLongIntHelper = type helper for LongInt
function TestA: LongInt;
function TestB: LongInt;
end;
TTest1Helper = type helper(TLongIntHelper) for Test1
function TestA: LongInt;
end;
TTest2Helper = type helper(TLongIntHelper) for Test2
function TestB: LongInt;
end;
TTest3Helper = type helper(TLongIntHelper) for Test3
end;
function TTest2Helper.TestB: LongInt;
begin
Result := 2;
end;
function TTest1Helper.TestA: LongInt;
begin
Result := 2;
end;
function TLongIntHelper.TestA: LongInt;
begin
Result := 1;
end;
function TLongIntHelper.TestB: LongInt;
begin
Result := 1;
end;
var
l: LongInt;
t1: Test1;
t2: Test2;
t3: Test3;
begin
if l.TestA <> 1 then
Halt(1);
if l.TestB <> 1 then
Halt(2);
if t1.TestA <> 2 then
Halt(3);
if t1.TestB <> 1 then
Halt(4);
if t2.TestA <> 1 then
Halt(5);
if t2.TestB <> 2 then
Halt(6);
if t3.TestA <> 1 then
Halt(7);
if t3.TestB <> 1 then
Halt(8);
end.

19
tests/test/tthlp31.pp Normal file
View File

@ -0,0 +1,19 @@
{ %FAIL }
program tthlp31;
{$mode objfpc}
{$modeswitch typehelpers}
type
Test = type LongInt;
TTestHelper = type helper for Test
end;
TLongIntHelper = type helper(TTestHelper) for LongInt
end;
begin
end.

30
tests/webtbs/tw40142.pp Normal file
View File

@ -0,0 +1,30 @@
{ %NORUN }
program tw40142;
{$Mode objfpc}{$H+}
{$ModeSwitch anonymousfunctions}
{$ModeSwitch functionreferences}
{$ModeSwitch nestedprocvars}
type
TVoidFunc = reference to procedure;
TFuncMaker = reference to function(const thing: string): TVoidFunc;
procedure main;
var
cool_bingo: TVoidFunc;
coolifier: TFuncMaker;
begin
coolifier := function (const thing: string) : TVoidFunc
begin
result := procedure begin writeln('cool ', thing) end;
end;
cool_bingo := coolifier('bingo');
cool_bingo();
end;
begin
main;
end.

69
tests/webtbs/tw40324.pp Normal file
View File

@ -0,0 +1,69 @@
program tw40324;
// This program compiles and runs in Delphi and in FPC. (at least should run in FPC)
// It is intentionally designed this way.
{$ifdef FPC}
{$mode objfpc}{$H+}
{$modeswitch functionreferences}
{$modeswitch anonymousfunctions}
// {$warn 5036 off}// "Warning: (5036) Local variable "$Capturer" does not seem to be initialized"
{$endif}
// uses
{$IFDEF UNIX}
cthreads,
{$ENDIF}
// Classes, Sysutils { you can add units after this };
type
T_X = String; // Type of Test-variable X
TfuncS = reference to function: T_X;
TfuncF = reference to function(s: T_X): TfuncS;
var f_inner: TfuncS;
f_outer: TfuncF;
//------------------------------------------------------------------------------
procedure caller;
begin
f_inner();
end;
//------------------------------------------------------------------------------
procedure main;
var X: T_X;
// str:String;
f_outer: TfuncF;
begin
X := '1234';
f_outer := function(s: T_X): TfuncS // This captures local and persistent copy of "X"
begin
Result := function: T_X
begin
Writeln(s);
Result := s;
end;
Writeln('Outer function was called');
end;
f_inner := f_outer(X); // This instantiates the outer function and f_inner and captures their local context.
X := '0'; // Erase the T_X content
Writeln('now calling f_inner');
caller(); // This line prints the T_X s=1234, which was captured by the outer function.
// f_inner will be called from an external context, this is just for test and demonstration
end;
//------------------------------------------------------------------------------
begin
main;
Writeln('Now the context of "main()" is lost. Can we still print the variable "X"?');
if f_inner() = '1234' then
Writeln('Yes! :-)')
else begin
Writeln('No! :-(');
Halt(1);
end;
//readln;
end.