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

git-svn-id: trunk@41684 -

packages/pastojs/src/fppas2js.pp

@@ -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

packages/pastojs/src/pas2jsfiler.pp

@@ -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;

packages/pastojs/tests/tcfiler.pas

@@ -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;',

utils/pas2js/docs/translation.html

@@ -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>