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

pastojs: made $DispatchField a modifier of the class, instead of a method

Browse Source 
git-svn-id: trunk@41684 -
This commit is contained in:
Mattias Gaertner 2019-03-12 12:10:59 +00:00
parent bfe148cfef
commit dec638761d
4 changed files with 51 additions and 88 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

48
packages/pastojs/src/fppas2js.pp
View File

@ -1132,9 +1132,7 @@ type
NewInstanceFunction: TPasClassFunction;
GUID: string;
// Dispatch and message modifiers:
DispatchProc: TPasProcedure;
DispatchField: String;
DispatchStrProc: TPasProcedure;
DispatchStrField: String;
MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // // not stored by filer
public
@ -3620,6 +3618,10 @@ begin
Scope:=TPas2JSClassScope(aClass.CustomData);
if Scope=nil then exit;
Scope.DispatchField:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchField];
Scope.DispatchStrField:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchStrField];
IntfList:=aClass.Interfaces;
GUIDs:=TStringList.Create;
try
@ -3838,7 +3840,7 @@ procedure TPas2JSResolver.FinishProcedureType(El: TPasProcedureType);
var
Proc: TPasProcedure;
pm: TProcedureModifier;
ExtName, s: String;
ExtName: String;
C: TClass;
AClassOrRec: TPasMembersType;
ClassOrRecScope: TPasClassOrRecordScope;
@ -4001,27 +4003,6 @@ begin
end;
end;
end;
if (Proc.ClassType=TPasProcedure) and (Proc.ProcType.Args.Count=1) then
begin
if SameText(Proc.Name,'Dispatch') then
begin
s:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchField];
if s<>'' then
begin
ClassScope.DispatchField:=s;
ClassScope.DispatchProc:=Proc;
end;
end
else if SameText(Proc.Name,'DispatchStr') then
begin
s:=CurrentParser.Scanner.CurrentValueSwitch[vsDispatchStrField];
if s<>'' then
begin
ClassScope.DispatchStrField:=s;
ClassScope.DispatchStrProc:=Proc;
end;
end;
end;
end
else
begin
@ -5552,11 +5533,20 @@ begin
end;
// field found -> check type
ComputeElement(TPasVariable(Member).VarType,MemberResolved,[rcType],Arg);
if not (MemberResolved.BaseType in btAllJSInteger) then
begin
LogMsg(20190311215215,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['integer field "'+FieldName+'"'],Arg);
exit;
end;
case Switch of
vsDispatchField:
if not (MemberResolved.BaseType in btAllJSInteger) then
begin
LogMsg(20190311215215,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['integer field "'+FieldName+'"'],Arg);
exit;
end;
vsDispatchStrField:
if not (MemberResolved.BaseType in btAllJSStrings) then
begin
LogMsg(20190312125025,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['string field "'+FieldName+'"'],Arg);
exit;
end;
end;
// check name case
if Member.Name<>FieldName then
begin

28
packages/pastojs/src/pas2jsfiler.pp
View File

@ -853,8 +853,6 @@ type
procedure Set_ClassScope_NewInstanceFunction(RefEl: TPasElement; Data: TObject);
procedure Set_ClassScope_DirectAncestor(RefEl: TPasElement; Data: TObject);
procedure Set_ClassScope_DefaultProperty(RefEl: TPasElement; Data: TObject);
procedure Set_ClassScope_DispatchProc(RefEl: TPasElement; Data: TObject);
procedure Set_ClassScope_DispatchStrProc(RefEl: TPasElement; Data: TObject);
procedure Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
procedure Set_ClassType_AncestorType(RefEl: TPasElement; Data: TObject);
procedure Set_ClassType_HelperForType(RefEl: TPasElement; Data: TObject);
@ -3497,10 +3495,8 @@ begin
AddReferenceToArray(Arr,Scope.AbstractProcs[i]);
end;
AddReferenceToObj(Obj,'DispatchProc',Scope.DispatchProc);
if Scope.DispatchField<>'' then
Obj.Add('DispatchField',Scope.DispatchField);
AddReferenceToObj(Obj,'DispatchStrProc',Scope.DispatchStrProc);
if Scope.DispatchStrField<>'' then
Obj.Add('DispatchStrField',Scope.DispatchStrField);
@ -4345,28 +4341,6 @@ begin
RaiseMsg(20180214115044,Scope.Element,GetObjName(RefEl));
end;
procedure TPCUReader.Set_ClassScope_DispatchProc(RefEl: TPasElement;
Data: TObject);
var
Scope: TPas2JSClassScope absolute Data;
begin
if RefEl is TPasProcedure then
Scope.DispatchProc:=TPasProcedure(RefEl) // no AddRef
else
RaiseMsg(20190311220755,Scope.Element,GetObjName(RefEl));
end;
procedure TPCUReader.Set_ClassScope_DispatchStrProc(RefEl: TPasElement;
Data: TObject);
var
Scope: TPas2JSClassScope absolute Data;
begin
if RefEl is TPasProcedure then
Scope.DispatchStrProc:=TPasProcedure(RefEl) // no AddRef
else
RaiseMsg(20190311220757,Scope.Element,GetObjName(RefEl));
end;
procedure TPCUReader.Set_ClassIntfMap_Intf(RefEl: TPasElement; Data: TObject);
var
Map: TPasClassIntfMap absolute Data;
@ -7042,8 +7016,6 @@ begin
El:=TPasClassType(Scope.Element);
ReadString(Obj,'DispatchField',Scope.DispatchField,El);
ReadString(Obj,'DispatchStrField',Scope.DispatchStrField,El);
ReadElementReference(Obj,Scope,'DispatchProc',@Set_ClassScope_DispatchProc);
ReadElementReference(Obj,Scope,'DispatchStrProc',@Set_ClassScope_DispatchStrProc);
end;
procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;

8
packages/pastojs/tests/tcfiler.pas
View File

@ -749,9 +749,7 @@ begin
CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
CheckRestoredReference(Path+'.DispatchProc',Orig.DispatchProc,Rest.DispatchProc);
AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
CheckRestoredReference(Path+'.DispatchStrProc',Orig.DispatchStrProc,Rest.DispatchStrProc);
AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
@ -2154,11 +2152,9 @@ begin
Add([
'interface',
'type',
' {$DispatchField DispInt}',
' {$DispatchStrField DispStr}',
' TObject = class',
' {$DispatchField DispInt}',
' procedure Dispatch(var Msg); virtual; abstract;',
' {$DispatchStrField DispStr}',
' procedure DispatchStr(var Msg); virtual; abstract;',
' end;',
' THopMsg = record',
' DispInt: longint;',

55
utils/pas2js/docs/translation.html
View File

@ -2274,34 +2274,39 @@ End.
<h2 id="dispatch">Dispatch messages</h2>
The procedure modifier <b>message</b> and the <b>Dispatch</b> works
similar to FPC/Delphi, as it expects a record of a specific format and
<b>Dispatch</b> calls the method with that message number or string.<br>
The procedure modifier <i>message &lt;integer&gt;</i> adds an entry to the
<i>$msgint</i> object, and modifier <i>message &lt;string&gt;</i> adds an entry
to the <i>$msgstr</i> object.<br>
Two new directives <i>{$DispatchField fieldname}</i> and <i>{$DispatchStrField fieldname}</i>
were added. Insert these directives in front of your dispatch methods
to let the compiler check all methods with message modifiers whether they
pass a record with the right field. For example:
<b><i>TObject.Dispatch</i></b> calls the corresponding method with that
message number or string.<br>
The procedure modifier <i>message &lt;integer&gt;</i> adds an entry to
hidden <i>YourClass.$msgint</i> object, while the modifier
<i>message &lt;string&gt;</i> adds an entry to the hidden
<i>YourClass.$msgstr</i> object.<br>
Two new directives <b><i>{$DispatchField fieldname}</i></b> and
<b><i>{$DispatchStrField fieldname}</i></b> were added. Insert these
directives in front of your class declaration to let the compiler check all
methods with message modifiers of this class and its descendants whether they
pass a record with the required field. For example:
<pre>
TMyComponent = class
{$DispatchField Msg}
procedure Dispatch(var aMessage); virtual;
{$DispatchField Msg} // enable checking message methods for record field name "Msg"
{$DispatchStrField MsgStr}
procedure DispatchStr(var aMessage); virtual;
end;
TMouseDownMsg = record
Id: integer; // Id instead of Msg, works in FPC, but not in pas2js
x,y: integer;
end;
TMouseUpMsg = record
MsgStr: string;
X,Y: integer;
end;
TWinControl = class
procedure MouseDownMsg(var Msg: TMouseDownMsg); message 3; // warning: Dispatch requires record field Msg
procedure MouseUpMsg(var Msg: TMouseUpMsg); message 'up'; // ok, record with string field name MsgStr
end;
TObject = class
procedure Dispatch(var aMessage); virtual;
procedure DispatchStr(var aMessage); virtual;
end;
TMouseDownMsg = record
Id: integer; // Id instead of Msg, works in FPC, but not in pas2js
x,y: integer;
end;
TMouseUpMsg = record
MsgStr: string;
X,Y: integer;
end;
TWinControl = class
procedure MouseDownMsg(var Msg: TMouseDownMsg); message 3; // warning: Dispatch requires record field Msg
procedure MouseUpMsg(var Msg: TMouseUpMsg); message 'up'; // ok, record with string field name MsgStr
end;
</pre>
Note that descendant classes can override the <i>$DispatchField</i> or
disable the check using <i>{$DispatchField -}</i>.
</div>