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

* Various small fixes

Browse Source
This commit is contained in:
Michaël Van Canneyt 2024-04-12 21:27:14 +02:00
parent 799b90ca3f
commit 3f8bbd3b00
4 changed files with 210 additions and 50 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
packages/webidl/src/webidldefs.pp
View File

@ -223,6 +223,8 @@ type
Function Add(aClass : TIDLDefinitionClass; Const AName : UTF8String; const aFile: string; aLine, aCol: integer) : TIDLDefinition; override;
Function Add(aItem : TIDLDefinition) : Integer;
Function Delete(aItem : TIDLDefinition) : boolean; // true if found and deleted
Function IndexOfName(aName : UTF8String) : Integer;
Function HasName(aName : UTF8String) : Boolean;
function GetEnumerator: TIDLDefinitionEnumerator;
Property Parent : TIDLDefinition Read FParent;
Property Definitions[aIndex : Integer] : TIDLDefinition Read GetD;default;
@ -1463,6 +1465,18 @@ begin
Result:=false;
end;
function TIDLDefinitionList.IndexOfName(aName: UTF8String): Integer;
begin
Result:=Count-1;
While (Result>=0) and (Definitions[Result].Name<>aName) do
Dec(Result);
end;
function TIDLDefinitionList.HasName(aName: UTF8String): Boolean;
begin
Result:=IndexOfName(aName)<>-1;
end;
function TIDLDefinitionList.GetEnumerator: TIDLDefinitionEnumerator;
begin
Result:=TIDLDefinitionEnumerator.Create(Self);

144
packages/webidl/src/webidltopas.pp
View File

@ -341,38 +341,46 @@ end;
function TBaseWebIDLToPas.WriteFunctionImplicitTypes(aList: TIDLDefinitionList): Integer;
procedure DoFunction(FD : TIDLFunctionDefinition);
var
D2,D3: TIDLDefinition;
DA: TIDLArgumentDefinition absolute D2;
UT: TIDLUnionTypeDefDefinition;
begin
if (FD.ReturnType is TIDLSequenceTypeDefDefinition) then
if AddSequenceDef(FD.ReturnType as TIDLSequenceTypeDefDefinition) then
Inc(Result);
For D2 in FD.Arguments do
if (DA.ArgumentType is TIDLSequenceTypeDefDefinition) then
begin
if AddSequenceDef(DA.ArgumentType as TIDLSequenceTypeDefDefinition) then
Inc(Result);
end
else
begin
UT:=CheckUnionTypeDefinition(DA.ArgumentType);
if Assigned(UT) then
For D3 in UT.Union do
if (D3 is TIDLSequenceTypeDefDefinition) then
if AddSequenceDef(D3 as TIDLSequenceTypeDefDefinition) then
Inc(Result);
end;
end;
Var
D,D2,D3: TIDLDefinition;
FD: TIDLFunctionDefinition absolute D;
DA: TIDLArgumentDefinition absolute D2;
UT: TIDLUnionTypeDefDefinition;
D : TIDLDefinition;
begin
Result:=0;
for D in aList do
if ConvertDef(D) then
if D is TIDLFunctionDefinition then
if Not (foCallBack in FD.Options) then
begin
if (FD.ReturnType is TIDLSequenceTypeDefDefinition) then
if AddSequenceDef(FD.ReturnType as TIDLSequenceTypeDefDefinition) then
Inc(Result);
For D2 in FD.Arguments do
if (DA.ArgumentType is TIDLSequenceTypeDefDefinition) then
begin
if AddSequenceDef(DA.ArgumentType as TIDLSequenceTypeDefDefinition) then
Inc(Result);
end
else
begin
UT:=CheckUnionTypeDefinition(DA.ArgumentType);
if Assigned(UT) then
For D3 in UT.Union do
if (D3 is TIDLSequenceTypeDefDefinition) then
if AddSequenceDef(D3 as TIDLSequenceTypeDefDefinition) then
Inc(Result);
end;
end;
DoFunction(TIDLFunctionDefinition(D))
else if D is TIDLCallBackDefinition then
DoFunction(TIDLCallBackDefinition(D).FunctionDef);
if Result>0 then
AddLn('');
end;
@ -611,6 +619,7 @@ function TBaseWebIDLToPas.WriteMapLikeMethodDefinitions(aParent: TIDLStructuredD
var
D1,KeyType,ValueType : String;
lReadOnly : Boolean;
L : TIDLDefinitionList;
begin
Result:=0;
@ -619,19 +628,33 @@ begin
// KeyType:=GetResolName();
// ValueType:=GetName(aMap.ValueType);
lReadOnly:=aMap.IsReadonly;
AddLn('function get(key: %s) : %s;',[KeyType,ValueType]);
AddLn('function has(key: %s) : Boolean;',[KeyType]);
AddLn('function entries : IJSIterator;');
AddLn('function keys : IJSIterator;');
AddLn('function values : IJSIterator;');
Inc(Result,5);
if not lReadOnly then
begin
AddLn('procedure set_(key: %s; value : %s);',[KeyType,ValueType]);
AddLn('procedure clear;');
AddLn('procedure delete(key: %s);');
Inc(Result,3);
end;
L:=TIDLDefinitionList.Create(Nil,False);
try
aParent.GetFullMemberList(L);
if Not L.HasName('get') then
AddLn('function get(key: %s) : %s;',[KeyType,ValueType]);
if Not L.HasName('has') then
AddLn('function has(key: %s) : Boolean;',[KeyType]);
if Not L.HasName('entries') then
AddLn('function entries : IJSIterator;');
if Not L.HasName('keys') then
AddLn('function keys : IJSIterator;');
if Not L.HasName('values') then
AddLn('function values : IJSIterator;');
Inc(Result,5);
if not lReadOnly then
begin
if Not L.HasName('set') then
AddLn('procedure set_(key: %s; value : %s);',[KeyType,ValueType]);
if Not L.HasName('clear') then
AddLn('procedure clear;');
if Not L.HasName('delete') then
AddLn('procedure delete(key: %s);',[KeyType]);
Inc(Result,3);
end;
finally
L.Free;
end;
end;
function TBaseWebIDLToPas.WriteUtilityMethods(Intf: TIDLStructuredDefinition
@ -1484,7 +1507,7 @@ begin
begin
CD:=TIDLArgumentDefinition.Create(Nil,aName,PosEl.SrcFile,PosEl.Line,PosEl.Column);
if PosEl is TIDLTypeDefDefinition then
CD.ArgumentType:=TIDLTypeDefDefinitionClass(Posel.ClassType).Create(CD,'',PosEl.SrcFile,PosEl.Line,PosEl.Column)
CD.ArgumentType:=TIDLTypeDefDefinition(PosEl).Clone(CD)
else
CD.ArgumentType:=TIDLTypeDefDefinition.Create(CD,'',PosEl.SrcFile,PosEl.Line,PosEl.Column);
CD.ArgumentType.TypeName:=aTypeName;
@ -1593,9 +1616,10 @@ function TBaseWebIDLToPas.CloneArgument(Arg: TIDLArgumentDefinition
): TIDLArgumentDefinition;
begin
Result:=Arg.Clone(nil);
ResolveTypeDef(Result);
ResolveTypeDef(Result.ArgumentType);
if Arg.Data<>nil then
Result.Data:=ClonePasData(TPasData(Arg.Data),Result);
// if Assigned(Result.ArgumentType)
end;
procedure TBaseWebIDLToPas.AddOverloads(aList: TFPObjectlist;
@ -1833,6 +1857,8 @@ begin
Indent;
WriteForwardClassDefs(Context.Definitions);
WriteEnumDefs(Context.Definitions);
// Callbacks
WriteFunctionImplicitTypes(Context.Definitions);
WriteTypeDefsAndCallbacks(Context.Definitions);
WriteDictionaryDefs(Context.Definitions);
WriteInterfaceDefs(Context.GetInterfacesTopologically);
@ -2215,8 +2241,46 @@ begin
end;
function TBaseWebIDLToPas.ConvertDef(D: TIDLDefinition): Boolean;
var
AD : TIDLAttributeDefinition absolute D;
FD : TIDLFunctionDefinition;
A,RT : TIDLDefinition;
FAD : TIDLArgumentDefinition absolute A;
RN,N : String;
begin
Result:=(coChromeWindow in BaseOptions) or Not D.HasSimpleAttribute('ChromeOnly');
if not Result then
exit;
if (D is TIDLAttributeDefinition) and Assigned(AD.AttributeType) then
begin
ResolveTypeDef(AD.AttributeType);
RT:=GetResolvedType(AD.AttributeType,N,RN);
Result:=ConvertDef(RT);
end
else if (D is TIDLFunctionDefinition) then
begin
FD:=TIDLFunctionDefinition(D);
For A in FD.Arguments do
begin
ResolveTypeDef(FAD.ArgumentType);
RT:=GetResolvedType(FAD.ArgumentType,N,RN);
Result:=ConvertDef(RT);
if not Result then break;
end;
end
else if (D is TIDLCallbackDefinition) then
begin
FD:=TIDLCallbackDefinition(D).FunctionDef;
For A in FD.Arguments do
begin
ResolveTypeDef(FAD.ArgumentType);
RT:=GetResolvedType(FAD.ArgumentType,N,RN);
Result:=ConvertDef(RT);
if not Result then break;
end;
end;
end;
function TBaseWebIDLToPas.FindGlobalDef(const aName: UTF8String

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

@ -1413,11 +1413,12 @@ var
begin
for I:=0 to Context.Definitions.Count-1 do
if Context.Definitions[i] is TIDLNamespaceDefinition then
begin
VarName:=Context.Definitions[i].Name;
VarType:=GetPasIntfName(Context.Definitions[i]);
AddLn(VarName+': '+VarType+';');
end;
if ConvertDef(Context.Definitions[i]) then
begin
VarName:=Context.Definitions[i].Name;
VarType:=GetPasIntfName(Context.Definitions[i]);
AddLn(VarName+': '+VarType+';');
end;
end;
procedure TWebIDLToPasWasmJob.WriteGlobalVar(aDef : String);
@ -1578,12 +1579,26 @@ end;
procedure TWebIDLToPasWasmJob.WriteMapLikeFunctionImplementations(aDef : TIDLStructuredDefinition; MD : TIDLMapLikeDefinition);
Var
L : TIDLDefinitionList;
begin
WriteMapLikeGetFunctionImplementation(aDef,MD);
WriteMapLikeHasFunctionImplementation(aDef,MD);
WriteMapLikeEntriesFunctionImplementation(aDef,MD);
WriteMapLikeKeysFunctionImplementation(aDef,MD);
WriteMapLikeValuesFunctionImplementation(aDef,MD);
L:=TIDLDefinitionList.Create(Nil,False);
try
aDef.GetFullMemberList(L);
if not L.HasName('get') then
WriteMapLikeGetFunctionImplementation(aDef,MD);
if not L.HasName('has') then
WriteMapLikeHasFunctionImplementation(aDef,MD);
if not L.HasName('entries') then
WriteMapLikeEntriesFunctionImplementation(aDef,MD);
if not L.HasName('keys') then
WriteMapLikeKeysFunctionImplementation(aDef,MD);
if not L.HasName('values') then
WriteMapLikeValuesFunctionImplementation(aDef,MD);
finally
L.Free;
end;
end;
procedure TWebIDLToPasWasmJob.WriteUtilityMethodImplementations(aDef : TIDLStructuredDefinition; ML : TIDLDefinitionList);

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

@ -70,6 +70,7 @@ type
procedure TestWJ_IntfFunction_DictionaryResult;
procedure TestWJ_IntfFunction_AliasResult;
procedure TestWJ_IntfFunction_NestedUnionSequence;
procedure TestWJ_intfFunction_UnionOptional;
// Namespace attribute
procedure TestWJ_NamespaceAttribute_Boolean;
// maplike
@ -1596,6 +1597,72 @@ begin
]);
end;
procedure TTestWebIDL2WasmJob.TestWJ_intfFunction_UnionOptional;
begin
TestwebIDL(
['interface Attr {',
' void roundRect((DOMString or sequence<DOMString>) a, optional long b);',
'};'
],[
'Type',
'',
' // Forward class definitions',
' IJSAttr = interface;',
' TJSAttr = class;',
'',
' { --------------------------------------------------------------------',
' TJSAttr',
' --------------------------------------------------------------------}',
' TUnicodeStringDynArray = IJSArray; // array of UnicodeString',
' IJSAttr = interface(IJSObject)',
' [''{AA94F48A-0CA1-3A6F-A546-208CA4B2AF2A}'']',
' procedure roundRect(const a: UnicodeString; aB: Integer); overload;',
' procedure roundRect(const a: TUnicodeStringDynArray; aB: Integer); overload;',
' procedure roundRect(const a: TUnicodeStringDynArray); overload;',
' procedure roundRect(const a: UnicodeString); overload;',
' end;',
'',
' TJSAttr = class(TJSObject,IJSAttr)',
' Private',
' Public',
' procedure roundRect(const a: UnicodeString; aB: Integer); overload;',
' procedure roundRect(const a: TUnicodeStringDynArray; aB: Integer); overload;',
' procedure roundRect(const a: TUnicodeStringDynArray); overload;',
' procedure roundRect(const a: UnicodeString); overload;',
' class function Cast(const Intf: IJSObject): IJSAttr;',
' end;',
'',
'implementation',
'',
'procedure TJSAttr.roundRect(const a: UnicodeString; aB: Integer); overload;',
'begin',
' InvokeJSNoResult(''roundRect'',[a,aB]);',
'end;',
'',
'procedure TJSAttr.roundRect(const a: TUnicodeStringDynArray; aB: Integer); overload;',
'begin',
' InvokeJSNoResult(''roundRect'',[a,aB]);',
'end;',
'',
'procedure TJSAttr.roundRect(const a: TUnicodeStringDynArray); overload;',
'begin',
' InvokeJSNoResult(''roundRect'',[a]);',
'end;',
'',
'procedure TJSAttr.roundRect(const a: UnicodeString); overload;',
'begin',
' InvokeJSNoResult(''roundRect'',[a]);',
'end;',
'',
'class function TJSAttr.Cast(const Intf: IJSObject): IJSAttr;',
'begin',
' Result:=TJSAttr.JOBCast(Intf);',
'end;',
'',
'end.'
]);
end;
procedure TTestWebIDL2WasmJob.TestWJ_NamespaceAttribute_Boolean;
begin