paweld/fpc
1
0
Fork 0
mirror of https://gitlab.com/freepascal.org/fpc/source.git synced 2025-09-25 20:13:32 +02:00
Code Issues Packages Projects Releases Wiki Activity

* Correctly create constructor definitions

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-04-09 17:04:09 +02:00
parent 38dac868e0
commit 3075a820a1
2 changed files with 104 additions and 30 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

77
packages/webidl/src/webidltowasmjob.pp
View File

@ -73,6 +73,7 @@ type
private
FPasInterfacePrefix: TIDLString;
FPasInterfaceSuffix: TIDLString;
FGeneratingInterface : Boolean;
function GetFunctionSuffix(aDef: TIDLFunctionDefinition; Overloads: TFPObjectList): String;
function GetInvokeClassName(aResultDef: TIDLDefinition; aName: TIDLString; aDef: TIDLFunctionDefinition=nil): TIDLString;
function GetInvokeNameFromTypeName(aTypeName: TIDLString; aType: TIDLDefinition): TIDLString;
@ -381,6 +382,7 @@ var
iIntf : TIDLInterfaceDefinition absolute Intf;
aPasIntfName, Decl, ParentName: TIDLString;
isNamespace : Boolean;
begin
Result:=1;
isNameSpace:=Intf is TIDLNamespaceDefinition;
@ -388,35 +390,40 @@ begin
// Pascal interface and ancestor
aPasIntfName:=GetPasIntfName(Intf);
FGeneratingInterface:=True;
try
Decl:=aPasIntfName+' = interface';
if (not IsNamespace) then
if Assigned(iIntf.ParentInterface) then
ParentName:=GetPasIntfName(iIntf.ParentInterface as TIDLInterfaceDefinition)
else
ParentName:=GetTypeName(Intf.ParentName);
if ParentName='' then
ParentName:=PasInterfacePrefix+'Object'+PasInterfaceSuffix;
if ParentName<>'' then
Decl:=Decl+'('+ParentName+')';
AddLn(Decl);
Decl:=aPasIntfName+' = interface';
if (not IsNamespace) then
if Assigned(iIntf.ParentInterface) then
ParentName:=GetPasIntfName(iIntf.ParentInterface as TIDLInterfaceDefinition)
else
ParentName:=GetTypeName(Intf.ParentName);
if ParentName='' then
ParentName:=PasInterfacePrefix+'Object'+PasInterfaceSuffix;
if ParentName<>'' then
Decl:=Decl+'('+ParentName+')';
AddLn(Decl);
Indent;
Indent;
// GUID
AddLn('['''+ComputeGUID(Decl,aMemberList)+''']');
// GUID
AddLn('['''+ComputeGUID(Decl,aMemberList)+''']');
// private members
WritePrivateGetters(Intf,aMemberList);
WritePrivateSetters(Intf,aMemberList);
// private members
WritePrivateGetters(Intf,aMemberList);
WritePrivateSetters(Intf,aMemberList);
// public members
WriteMethodDefs(Intf,aMemberList);
WriteProperties(Intf,aMemberList);
// public members
WriteMethodDefs(Intf,aMemberList);
WriteProperties(Intf,aMemberList);
Undent;
AddLn('end;');
AddLn('');
Undent;
AddLn('end;');
AddLn('');
finally
FGeneratingInterface:=False;
end;
end;
function TWebIDLToPasWasmJob.WritePrivateGetters(aParent: TIDLStructuredDefinition;
@ -588,7 +595,9 @@ begin
if (foConstructor in aDef.Options) then
begin
FuncName:='New';
writeln('Note: skipping constructor of '+aDef.Parent.Name+' at '+GetDefPos(aDef));
InvokeName:= 'InvokeJSObjectResult';
ResolvedReturnTypeName:=aParent.Name;
ReturnTypeName:=GetName(aParent);
exit(Nil);
end
else
@ -617,12 +626,14 @@ var
begin
Result:='';
Args:=GetArguments(ArgDefList,False);
if (aReturnTypeName='') then
if (foConstructor in aDef.Options) then
begin
if not (foConstructor in aDef.Options) then
ProcKind:='procedure'
else
ProcKind:='constructor';
ProcKind:='class function';
Result:='Create'+Args+' : '+aReturnTypeName;
end
else if (aReturnTypeName='') then
begin
ProcKind:='procedure';
Result:=aFuncName+Args;
end
else
@ -727,7 +738,10 @@ begin
end;
Args:=',['+Args+']';
InvokeCode:=InvokeCode+InvokeName+'('''+aDef.Name+''''+Args;
if foConstructor in aDef.Options then
InvokeCode:=InvokeCode+InvokeName+'('''+ResolvedReturnTypeName+''''+Args+','+ReturnTypeName
else
InvokeCode:=InvokeCode+InvokeName+'('''+aDef.Name+''''+Args;
if InvokeClassName<>'' then
InvokeCode:=InvokeCode+','+InvokeClassName+') as '+ReturnTypeName
else
@ -798,6 +812,9 @@ begin
writeln('Note: skipping Getter of '+aDef.Parent.Name+' at '+GetDefPos(aDef));
exit(false);
end;
if (foConstructor in aDef.Options) then
if FGeneratingInterface then
exit;
Suff:='';
ReturnDef:=GetMethodInfo(aParent,aDef,FuncName,ReturnTypeName,ResolvedReturnTypeName,InvokeName,InvokeClassName);
Overloads:=GetOverloads(ADef);

57
packages/webidl/tests/tcwebidl2wasmjob.pas
View File

@ -48,6 +48,8 @@ type
procedure TestWJ_IntfFunction_Promise;
procedure TestWJ_IntfFunction_ArgAny;
procedure TestWJ_IntfFunction_EnumResult;
procedure TestWJ_IntfFunction_SequenceArg;
procedure TestWJ_IntfFunction_Constructor;
// Namespace attribute
procedure TestWJ_NamespaceAttribute_Boolean;
// maplike
@ -774,6 +776,61 @@ begin
]);
end;
procedure TTestWebIDL2WasmJob.TestWJ_IntfFunction_SequenceArg;
begin
TestWebIDL([
'namespace Attr {',
' boolean vibrate(sequence<long> pattern);',
'};',
''],
[]);
end;
procedure TTestWebIDL2WasmJob.TestWJ_IntfFunction_Constructor;
begin
TestWebIDL([
'interface Attr {',
' constructor(long options); ',
'};'
],
['Type',
' // Forward class definitions',
' IJSAttr = interface;',
' TJSAttr = class;',
' { --------------------------------------------------------------------',
' TJSAttr',
' --------------------------------------------------------------------}',
'',
' IJSAttr = interface(IJSObject)',
' [''{AA94F48A-EA1E-381A-A2A6-208CA4B2AF2A}'']',
' end;',
'',
' TJSAttr = class(TJSObject,IJSAttr)',
' Private',
' Public',
' class function Create(aOptions : Integer) : TJSAttr;',
' class function Cast(const Intf: IJSObject): IJSAttr;',
' end;',
'',
'implementation',
'',
'class function TJSAttr.Create(aOptions: Integer) : TJSAttr;',
'begin',
' Result:=InvokeJSObjectResult(''Attr'',[aOptions],TJSAttr);',
'end;',
'',
'class function TJSAttr.Cast(const Intf: IJSObject): IJSAttr;',
'begin',
' Result:=TJSAttr.JOBCast(Intf);',
'end;',
'',
'end.',
'']);
end;
procedure TTestWebIDL2WasmJob.TestWJ_NamespaceAttribute_Boolean;
begin
TestWebIDL([