From 3075a820a1369fb7692bf6f76bcf1cb90150d2f8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Micha=C3=ABl=20Van=20Canneyt?= <michael@freepascal.org>
Date: Tue, 9 Apr 2024 17:04:09 +0200
Subject: [PATCH] * Correctly create constructor definitions

---
 packages/webidl/src/webidltowasmjob.pp     | 77 +++++++++++++---------
 packages/webidl/tests/tcwebidl2wasmjob.pas | 57 ++++++++++++++++
 2 files changed, 104 insertions(+), 30 deletions(-)

diff --git a/packages/webidl/src/webidltowasmjob.pp b/packages/webidl/src/webidltowasmjob.pp
index abd29e3b5c..3dba2242d2 100644
--- a/packages/webidl/src/webidltowasmjob.pp
+++ b/packages/webidl/src/webidltowasmjob.pp
@@ -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);
diff --git a/packages/webidl/tests/tcwebidl2wasmjob.pas b/packages/webidl/tests/tcwebidl2wasmjob.pas
index de880307a9..16324e967f 100644
--- a/packages/webidl/tests/tcwebidl2wasmjob.pas
+++ b/packages/webidl/tests/tcwebidl2wasmjob.pas
@@ -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([