Browse Source

* Fix code generation for dictionary with parent

Michaël Van Canneyt 1 year ago
parent
commit
f89a2b8432

+ 16 - 1
packages/webidl/src/webidltopas.pp

@@ -177,6 +177,7 @@ type
     procedure AddGlobalJSIdentifier(D: TIDLDefinition); virtual;
     procedure ResolveParentInterfaces(aList: TIDLDefinitionList); virtual;
     procedure ResolveParentInterface(Intf: TIDLInterfaceDefinition); virtual;
+    procedure ResolveParentInterface(Intf: TIDLDictionaryDefinition); virtual;
     procedure ResolveTypeDefs(aList: TIDLDefinitionList); virtual;
     procedure ResolveTypeDef(D: TIDLDefinition); virtual;
     procedure RemoveInterfaceForwards(aList: TIDLDefinitionList); virtual;
@@ -2689,7 +2690,9 @@ var
 begin
   For D in aList do
     if D is TIDLInterfaceDefinition then
-      ResolveParentInterface(TIDLInterfaceDefinition(D));
+      ResolveParentInterface(TIDLInterfaceDefinition(D))
+    else if D is TIDLDictionaryDefinition then
+      ResolveParentInterface(TIDLDictionaryDefinition(D));
 end;
 
 procedure TBaseWebIDLToPas.ResolveParentInterface(Intf: TIDLInterfaceDefinition
@@ -2704,6 +2707,18 @@ begin
     Intf.ParentInterface:=TIDLInterfaceDefinition(aDef);
 end;
 
+procedure TBaseWebIDLToPas.ResolveParentInterface(Intf: TIDLDictionaryDefinition
+  );
+var
+  aDef: TIDLDefinition;
+begin
+  if Intf.ParentDictionary<>nil then exit;
+  if Intf.ParentName='' then exit;
+  aDef:=FindGlobalDef(Intf.ParentName);
+  if aDef is TIDLDictionaryDefinition then
+    Intf.ParentDictionary:=TIDLDictionaryDefinition(aDef);
+end;
+
 procedure TBaseWebIDLToPas.ResolveTypeDefs(aList: TIDLDefinitionList);
 var
   D: TIDLDefinition;

+ 1 - 1
packages/webidl/src/webidltowasmjob.pp

@@ -493,7 +493,7 @@ begin
       else
         ParentName:=GetPascalTypeName(Intf.ParentName);
     sdDictionary:
-      if Assigned(dDict.ParentDictionary) then
+       if Assigned(dDict.ParentDictionary) then
         ParentName:=GetPasIntfName(dDict.ParentDictionary as TIDLDictionaryDefinition)
        else
         ParentName:=GetPascalTypeName(dDict.ParentName);

+ 115 - 0
packages/webidl/tests/tcwebidl2wasmjob.pas

@@ -51,6 +51,7 @@ type
     procedure TestWJ_Typedef_Sequence;
     procedure TestWJ_Typedef_Aliased;
     procedure TestWJ_Typedef_Dictionary;
+    procedure TestWJ_Typedef_DictionaryWithParent;
 
     // attributes
     procedure TestWJ_IntfAttribute_Boolean;
@@ -552,6 +553,120 @@ begin
   '']);
 end;
 
+procedure TTestWebIDL2WasmJob.TestWJ_Typedef_DictionaryWithParent;
+begin
+  TestWebIDL([
+  'dictionary Attr {',
+  '  boolean aBoolean;',
+  '};',
+  'dictionary Attr2 : Attr {',
+  '  long aLong;',
+  '};',
+  ''],
+  ['Type',
+  '  // Forward class definitions',
+  '  IJSAttr = interface;',
+  '  TJSAttr = class;',
+  '  IJSAttr2 = interface;',
+  '  TJSAttr2 = class;',
+  '  { --------------------------------------------------------------------',
+  '    TJSAttr',
+  '    --------------------------------------------------------------------}',
+  '',
+  '  TJSAttrRec = record',
+  '    aBoolean: Boolean;',
+  '  end;',
+  '',
+  '  IJSAttr = interface(IJSObject)',
+  '    ['''+FixedGUID+''']',
+  '    function _GetaBoolean: Boolean;',
+  '    procedure _SetaBoolean(const aValue: Boolean);',
+  '    property aBoolean: Boolean read _GetaBoolean write _SetaBoolean;',
+  '  end;',
+  '',
+  '  TJSAttr = class(TJSObject,IJSAttr)',
+  '  Private',
+  '    function _GetaBoolean: Boolean;',
+  '    procedure _SetaBoolean(const aValue: Boolean);',
+  '  Public',
+  '    class function JSClassName: UnicodeString; override;',
+  '    class function Cast(const Intf: IJSObject): IJSAttr;',
+  '    property aBoolean: Boolean read _GetaBoolean write _SetaBoolean;',
+  '  end;',
+  '',
+  '  { --------------------------------------------------------------------',
+  '    TJSAttr2',
+  '    --------------------------------------------------------------------}',
+  '',
+  '  TJSAttr2Rec = record',
+  '    aLong: LongInt;',
+  '    aBoolean: Boolean;',
+  '  end;',
+  '',
+  '  IJSAttr2 = interface(IJSAttr)',
+  '    ['''+FixedGUID+''']',
+  '    function _GetaLong: LongInt;',
+  '    procedure _SetaLong(const aValue: LongInt);',
+  '    property aLong: LongInt read _GetaLong write _SetaLong;',
+  '  end;',
+  '',
+  '  TJSAttr2 = class(TJSAttr,IJSAttr2)',
+  '  Private',
+  '    function _GetaLong: LongInt;',
+  '    procedure _SetaLong(const aValue: LongInt);',
+  '  Public',
+  '    class function JSClassName: UnicodeString; override;',
+  '    class function Cast(const Intf: IJSObject): IJSAttr2;',
+  '    property aLong: LongInt read _GetaLong write _SetaLong;',
+  '  end;',
+  '',
+  'implementation',
+  '',
+  'function TJSAttr._GetaBoolean: Boolean;',
+  'begin',
+  '  Result:=ReadJSPropertyBoolean(''aBoolean'');',
+  'end;',
+  '',
+  'procedure TJSAttr._SetaBoolean(const aValue: Boolean);',
+  'begin',
+  '  WriteJSPropertyBoolean(''aBoolean'',aValue);',
+  'end;',
+  '',
+  'class function TJSAttr.JSClassName: UnicodeString;',
+  'begin',
+  '  Result:=''Object'';',
+  'end;',
+  '',
+  'class function TJSAttr.Cast(const Intf: IJSObject): IJSAttr;',
+  'begin',
+  '  Result:=TJSAttr.JOBCast(Intf);',
+  'end;',
+  '',
+  'function TJSAttr2._GetaLong: LongInt;',
+  'begin',
+  '  Result:=ReadJSPropertyLongInt(''aLong'');',
+  'end;',
+  '',
+  'procedure TJSAttr2._SetaLong(const aValue: LongInt);',
+  'begin',
+  '  WriteJSPropertyLongInt(''aLong'',aValue);',
+  'end;',
+  '',
+  'class function TJSAttr2.JSClassName: UnicodeString;',
+  'begin',
+  '  Result:=''Object'';',
+  'end;',
+  '',
+  'class function TJSAttr2.Cast(const Intf: IJSObject): IJSAttr2;',
+  'begin',
+  '  Result:=TJSAttr2.JOBCast(Intf);',
+  'end;',
+  '',
+  'end.',
+  '']);
+
+end;
+
 procedure TTestWebIDL2WasmJob.TestWJ_IntfAttribute_Boolean;
 begin
   TestWebIDL([

+ 2 - 2
packages/webidl/tests/testidl.lpi

@@ -22,13 +22,13 @@
     </PublishOptions>
     <RunParams>
       <local>
-        <CommandLineParams Value="--suite=TTestWebIDL2WasmJob.TestWJ_Typedef_Dictionary"/>
+        <CommandLineParams Value="--suite=TTestWebIDL2WasmJob.TestWJ_Typedef_DictionaryWithParent"/>
       </local>
       <FormatVersion Value="2"/>
       <Modes Count="1">
         <Mode0 Name="default">
           <local>
-            <CommandLineParams Value="--suite=TTestWebIDL2WasmJob.TestWJ_Typedef_Dictionary"/>
+            <CommandLineParams Value="--suite=TTestWebIDL2WasmJob.TestWJ_Typedef_DictionaryWithParent"/>
           </local>
         </Mode0>
       </Modes>