* synchronize with trunk

git-svn-id: branches/unicodekvm@41689 -

packages/fcl-passrc/src/pscanner.pp

@@ -79,6 +79,7 @@ const
   nErrIncludeLimitReached = 1028;
   nMisplacedGlobalCompilerSwitch = 1029;
   nLogMacroXSetToY = 1030;
+  nInvalidDispatchFieldName = 1031;
 
 // resourcestring patterns of messages
 resourcestring
@@ -114,6 +115,7 @@ resourcestring
   SErrIncludeLimitReached = 'Include file limit reached';
   SMisplacedGlobalCompilerSwitch = 'Misplaced global compiler switch, ignored';
   SLogMacroXSetToY = 'Macro %s set to %s';
+  SInvalidDispatchFieldName = 'Invalid Dispatch field name';
 
 type
   TMessageType = (
@@ -378,13 +380,19 @@ const
 
 type
   TValueSwitch = (
-    vsInterfaces
+    vsInterfaces,
+    vsDispatchField,
+    vsDispatchStrField
     );
   TValueSwitches = set of TValueSwitch;
   TValueSwitchArray = array[TValueSwitch] of string;
 const
   vsAllValueSwitches = [low(TValueSwitch)..high(TValueSwitch)];
-  DefaultVSInterfaces = 'com';
+  DefaultValueSwitches: array[TValueSwitch] of string = (
+     'com', // vsInterfaces
+     'Msg', // vsDispatchField
+     'MsgStr' // vsDispatchStrField
+     );
   DefaultMaxIncludeStackDepth = 20;
 
 type
@@ -765,6 +773,8 @@ type
     function HandleDirective(const ADirectiveText: String): TToken; virtual;
     function HandleLetterDirective(Letter: char; Enable: boolean): TToken; virtual;
     procedure HandleBoolDirective(bs: TBoolSwitch; const Param: String); virtual;
+    procedure DoHandleDirective(Sender: TObject; Directive, Param: String;
+      var Handled: boolean); virtual;
     procedure HandleIFDEF(const AParam: String);
     procedure HandleIFNDEF(const AParam: String);
     procedure HandleIFOPT(const AParam: String);
@@ -773,6 +783,7 @@ type
     procedure HandleELSE(const AParam: String);
     procedure HandleENDIF(const AParam: String);
     procedure HandleDefine(Param: String); virtual;
+    procedure HandleDispatchField(Param: String; vs: TValueSwitch); virtual;
     procedure HandleError(Param: String); virtual;
     procedure HandleMessageDirective(Param: String); virtual;
     procedure HandleIncludeFile(Param: String); virtual;
@@ -1108,7 +1119,9 @@ const
     );
 
   ValueSwitchNames: array[TValueSwitch] of string = (
-    'Interfaces'
+    'Interfaces', // vsInterfaces
+    'DispatchField', // vsDispatchField
+    'DispatchStrField' // vsDispatchStrField
     );
 
 const
@@ -2657,6 +2670,8 @@ constructor TPascalScanner.Create(AFileResolver: TBaseFileResolver);
     Result.Duplicates:=dupError;
   end;
 
+var
+  vs: TValueSwitch;
 begin
   inherited Create;
   FFileResolver := AFileResolver;
@@ -2671,7 +2686,8 @@ begin
   FCurrentBoolSwitches:=bsFPCMode;
   FAllowedBoolSwitches:=bsAll;
   FAllowedValueSwitches:=vsAllValueSwitches;
-  FCurrentValueSwitches[vsInterfaces]:=DefaultVSInterfaces;
+  for vs in TValueSwitch do
+    FCurrentValueSwitches[vs]:=DefaultValueSwitches[vs];
 
   FConditionEval:=TCondDirectiveEvaluator.Create;
   FConditionEval.OnLog:=@OnCondEvalLog;
@@ -3297,6 +3313,26 @@ begin
     end;
 end;
 
+procedure TPascalScanner.HandleDispatchField(Param: String; vs: TValueSwitch);
+var
+  NewValue: String;
+begin
+  if not (vs in AllowedValueSwitches) then
+    Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
+  NewValue:=ReadIdentifier(Param);
+  if NewValue='-' then
+    NewValue:=''
+  else if not IsValidIdent(NewValue,false) then
+    DoLog(mtWarning,nInvalidDispatchFieldName,SInvalidDispatchFieldName,[]);
+  if SameText(NewValue,CurrentValueSwitch[vs]) then exit;
+  if vs in ReadOnlyValueSwitches then
+    begin
+    Error(nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,[ValueSwitchNames[vs]]);
+    exit;
+    end;
+  CurrentValueSwitch[vs]:=NewValue;
+end;
+
 procedure TPascalScanner.HandleError(Param: String);
 begin
   if po_StopOnErrorDirective in Options then
@@ -3682,6 +3718,10 @@ begin
           HandleDefine(Param);
         'GOTO':
           DoBoolDirective(bsGoto);
+        'DIRECTIVEFIELD':
+          HandleDispatchField(Param,vsDispatchField);
+        'DIRECTIVESTRFIELD':
+          HandleDispatchField(Param,vsDispatchStrField);
         'ERROR':
           HandleError(Param);
         'HINT':
@@ -3735,8 +3775,7 @@ begin
       end;
       end;
 
-    if Assigned(OnDirective) then
-      OnDirective(Self,Directive,Param,Handled);
+    DoHandleDirective(Self,Directive,Param,Handled);
     if (not Handled) then
       if LogEvent(sleDirective) then
         DoLog(mtWarning,nWarnIllegalCompilerDirectiveX,sWarnIllegalCompilerDirectiveX,
@@ -3801,6 +3840,13 @@ begin
     CurrentBoolSwitches:=CurrentBoolSwitches-[bs];
 end;
 
+procedure TPascalScanner.DoHandleDirective(Sender: TObject; Directive,
+  Param: String; var Handled: boolean);
+begin
+  if Assigned(OnDirective) then
+    OnDirective(Self,Directive,Param,Handled);
+end;
+
 function TPascalScanner.DoFetchToken: TToken;
 var
   TokenStart: {$ifdef UsePChar}PChar{$else}integer{$endif};

packages/pastojs/src/fppas2js.pp

@@ -522,6 +522,7 @@ const
   nHelperClassMethodForExtClassMustBeStatic = 4027;
   nBitWiseOperationIs32Bit = 4028;
   nDuplicateMessageIdXAtY = 4029;
+  nDispatchRequiresX = 4030;
 // resourcestring patterns of messages
 resourcestring
   sPasElementNotSupported = 'Pascal element not supported: %s';
@@ -553,6 +554,7 @@ resourcestring
   sHelperClassMethodForExtClassMustBeStatic = 'Helper class method for external class must be static';
   sBitWiseOperationIs32Bit = 'Bitwise operation is 32-bit';
   sDuplicateMessageIdXAtY = 'Duplicate message id "%s" at %s';
+  sDispatchRequiresX = 'Dispatch requires %s';
 
 const
   ExtClassBracketAccessor = '[]'; // external name '[]' marks the array param getter/setter
@@ -1129,7 +1131,11 @@ type
   public
     NewInstanceFunction: TPasClassFunction;
     GUID: string;
-    MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // temporary lists, not stored by filer!
+    // Dispatch and message modifiers:
+    DispatchField: String;
+    DispatchStrField: String;
+    MsgIntToProc, MsgStrToProc: TMessageIdToProc_List; // // not stored by filer
+  public
     destructor Destroy; override;
   end;
 
@@ -1194,10 +1200,10 @@ const
     msOmitRTTI,
     msMultiHelpers];
 
-  msAllPas2jsBoolSwitchesReadOnly = [
+  bsAllPas2jsBoolSwitchesReadOnly = [
     bsLongStrings
     ];
-  msAllPas2jsBoolSwitches = msAllPas2jsBoolSwitchesReadOnly+[
+  bsAllPas2jsBoolSwitches = bsAllPas2jsBoolSwitchesReadOnly+[
     bsAssertions,
     bsRangeChecks,
     bsWriteableConst,
@@ -1211,6 +1217,13 @@ const
     bsObjectChecks
     ];
 
+  vsAllPas2jsValueSwitchesReadOnly = [];
+  vsAllPas2jsValueSwitches = vsAllPas2jsValueSwitchesReadOnly+[
+    vsInterfaces,
+    vsDispatchField,
+    vsDispatchStrField
+    ];
+
   // default parser+scanner options
   po_Pas2js = po_Resolver+[
     po_AsmWhole,
@@ -1417,8 +1430,9 @@ type
     function HasStaticArrayCloneFunc(Arr: TPasArrayType): boolean;
     function IsTGUID(TypeEl: TPasRecordType): boolean; override;
     function GetAssignGUIDString(TypeEl: TPasRecordType; Expr: TPasExpr; out GUID: TGuid): boolean;
+    procedure CheckDispatchField(Proc: TPasProcedure; Switch: TValueSwitch);
     procedure AddMessageStr(var MsgToProc: TMessageIdToProc_List; const S: string; Proc: TPasProcedure);
-    procedure AddMessageIdToClassScope(Proc: TPasProcedure); virtual;
+    procedure AddMessageIdToClassScope(Proc: TPasProcedure; EmitHints: boolean); virtual;
     // CustomData
     function GetElementData(El: TPasElementBase;
       DataClass: TPas2JsElementDataClass): TPas2JsElementData; virtual;
@@ -3567,6 +3581,10 @@ begin
     until false;
     end;
   end;
+
+  // clear
+  Scope.MsgIntToProc:=nil;
+  Scope.MsgStrToProc:=nil;
   //writeln('TPas2JSResolver.FinishClassType END ',GetObjName(El));
 end;
 
@@ -3600,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
@@ -3882,7 +3904,7 @@ begin
         RaiseMsg(20190303231445,nInvalidXModifierY,sInvalidXModifierY,['message','at non class method'],Proc.MessageExpr);
       if TPasClassType(Proc.Parent).IsExternal then
         RaiseMsg(20190304002235,nInvalidXModifierY,sInvalidXModifierY,['message','in external class'],Proc.MessageExpr);
-      AddMessageIdToClassScope(Proc);
+      AddMessageIdToClassScope(Proc,true);
       end;
 
     if Proc.Parent is TPasMembersType then
@@ -5446,6 +5468,97 @@ begin
   end;
 end;
 
+procedure TPas2JSResolver.CheckDispatchField(Proc: TPasProcedure;
+  Switch: TValueSwitch);
+var
+  ProcScope: TPas2JSProcedureScope;
+  ClassScope: TPas2JSClassScope;
+  FieldName: String;
+  Args, Members: TFPList;
+  Arg: TPasArgument;
+  ArgType: TPasType;
+  i: Integer;
+  Member: TPasElement;
+  MemberResolved: TPasResolverResult;
+begin
+  Args:=Proc.ProcType.Args;
+  if Args.Count<>1 then
+    RaiseNotYetImplemented(20190311213959,Proc);
+  Arg:=TPasArgument(Args[0]);
+  if Arg.ArgType=nil then
+    exit; // untyped arg
+
+  ProcScope:=TPas2JSProcedureScope(Proc.CustomData);
+  ClassScope:=TPas2JSClassScope(ProcScope.ClassRecScope);
+  FieldName:='';
+  while ClassScope<>nil do
+    begin
+    case Switch of
+    vsDispatchField:
+      if ClassScope.DispatchField<>'' then
+        begin
+        FieldName:=ClassScope.DispatchField;
+        break;
+        end;
+    vsDispatchStrField:
+      if ClassScope.DispatchStrField<>'' then
+        begin
+        FieldName:=ClassScope.DispatchStrField;
+        break;
+        end;
+    else
+      RaiseNotYetImplemented(20190311213650,Proc,'');
+    end;
+    ClassScope:=ClassScope.AncestorScope as TPas2JSClassScope;
+    end;
+  if FieldName='' then exit;
+
+  // there is a Dispatch(str) method with a directive -> check field
+  ArgType:=ResolveAliasType(Arg.ArgType);
+  if not (ArgType is TPasMembersType) then
+    begin
+    LogMsg(20190311214257,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['record type'],Arg);
+    exit;
+    end;
+  Members:=TPasMembersType(ArgType).Members;
+  for i:=0 to Members.Count-1 do
+    begin
+    Member:=TPasElement(Members[i]);
+    if SameText(Member.Name,FieldName) then
+      begin
+      if Member.ClassType<>TPasVariable then
+        begin
+        LogMsg(20190311215218,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['field variable "'+FieldName+'"'],Arg);
+        exit;
+        end;
+      // field found -> check type
+      ComputeElement(TPasVariable(Member).VarType,MemberResolved,[rcType],Arg);
+      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
+        LogMsg(20190311221651,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['field name to match exactly "'+FieldName+'"'],Arg);
+        exit;
+        end;
+      exit;
+      end;
+    end;
+  LogMsg(20190311214710,mtWarning,nDispatchRequiresX,sDispatchRequiresX,['record field "'+FieldName+'"'],Arg);
+end;
+
 procedure TPas2JSResolver.AddMessageStr(var MsgToProc: TMessageIdToProc_List;
   const S: string; Proc: TPasProcedure);
 var
@@ -5464,7 +5577,8 @@ begin
   MsgToProc.AddObject(S,Proc);
 end;
 
-procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure);
+procedure TPas2JSResolver.AddMessageIdToClassScope(Proc: TPasProcedure;
+  EmitHints: boolean);
 var
   AClass: TPasClassType;
   ClassScope: TPas2JSClassScope;
@@ -5481,12 +5595,24 @@ begin
     case Value.Kind of
     {$ifdef FPC_HAS_CPSTRING}
     revkString:
+      begin
       AddMessageStr(ClassScope.MsgStrToProc,ExprEvaluator.GetUTF8Str(TResEvalString(Value).S,Expr),Proc);
+      if EmitHints then
+        CheckDispatchField(Proc,vsDispatchStrField);
+      end;
     {$ENDIF}
     revkUnicodeString:
+      begin
       AddMessageStr(ClassScope.MsgStrToProc,String(TResEvalUTF16(Value).S),Proc);
+      if EmitHints then
+        CheckDispatchField(Proc,vsDispatchStrField);
+      end;
     revkInt:
+      begin
       AddMessageStr(ClassScope.MsgIntToProc,IntToStr(TResEvalInt(Value).Int),Proc);
+      if EmitHints then
+        CheckDispatchField(Proc,vsDispatchField);
+      end
     else
       RaiseXExpectedButYFound(20190303225849,'integer constant',Value.AsString,Expr);
     end;
@@ -13240,7 +13366,7 @@ begin
             continue;
             end
           else if (Proc.MessageExpr<>nil) and (aResolver<>nil) then
-            aResolver.AddMessageIdToClassScope(Proc);
+            aResolver.AddMessageIdToClassScope(Proc,false);
           NewEl:=ConvertProcedure(Proc,FuncContext);
           if NewEl=nil then
             continue; // e.g. abstract or external proc

packages/pastojs/src/pas2jscompiler.pp

@@ -1044,9 +1044,11 @@ begin
   Scanner.AllowedModeSwitches:=msAllPas2jsModeSwitches;
   Scanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
   Scanner.CurrentModeSwitches:=GetInitialModeSwitches;
-  Scanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
-  Scanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
+  Scanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
+  Scanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
   Scanner.CurrentBoolSwitches:=GetInitialBoolSwitches;
+  Scanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
+  Scanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
   Scanner.CurrentValueSwitch[vsInterfaces]:=InterfaceTypeNames[Compiler.InterfaceType];
   if coAllowCAssignments in Compiler.Options then
     Scanner.Options:=Scanner.Options+[po_cassignments];

packages/pastojs/src/pas2jsfiler.pp

@@ -971,6 +971,7 @@ type
     procedure ReadClassIntfMapProcs(Obj: TJSONObject; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
     procedure ReadClassIntfMap(Obj: TJSONObject; Scope: TPas2JSClassScope; Map: TPasClassIntfMap; OrigIntfType: TPasType); virtual;
     procedure ReadClassScopeInterfaces(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
+    procedure ReadClassScopeDispatchProcs(Obj: TJSONObject; Scope: TPas2JSClassScope); virtual;
     procedure ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope; aContext: TPCUReaderContext); virtual;
     procedure ReadClassType(Obj: TJSONObject; El: TPasClassType; aContext: TPCUReaderContext); virtual;
     procedure ReadArgument(Obj: TJSONObject; El: TPasArgument; aContext: TPCUReaderContext); virtual;
@@ -3494,6 +3495,11 @@ begin
       AddReferenceToArray(Arr,Scope.AbstractProcs[i]);
     end;
 
+  if Scope.DispatchField<>'' then
+    Obj.Add('DispatchField',Scope.DispatchField);
+  if Scope.DispatchStrField<>'' then
+    Obj.Add('DispatchStrField',Scope.DispatchStrField);
+
   if Scope.GUID<>'' then
     Obj.Add('SGUID',Scope.GUID);
 
@@ -7002,6 +7008,16 @@ begin
     end;
 end;
 
+procedure TPCUReader.ReadClassScopeDispatchProcs(Obj: TJSONObject;
+  Scope: TPas2JSClassScope);
+var
+  El: TPasClassType;
+begin
+  El:=TPasClassType(Scope.Element);
+  ReadString(Obj,'DispatchField',Scope.DispatchField,El);
+  ReadString(Obj,'DispatchStrField',Scope.DispatchStrField,El);
+end;
+
 procedure TPCUReader.ReadClassScope(Obj: TJSONObject; Scope: TPas2JSClassScope;
   aContext: TPCUReaderContext);
 var
@@ -7098,10 +7114,13 @@ begin
   ReadElementList(Obj,El,'Members',El.Members,
     {$IFDEF CheckPasTreeRefCount}'TPasClassType.Members'{$ELSE}true{$ENDIF},
     aContext);
+
+
   if Scope<>nil then
     begin
     ReadClassScopeAbstractProcs(Obj,Scope);
     ReadClassScopeInterfaces(Obj,Scope);
+    ReadClassScopeDispatchProcs(Obj,Scope);
 
     if El.ObjKind in okAllHelpers then
       begin

packages/pastojs/tests/tcfiler.pas

@@ -161,6 +161,7 @@ type
     procedure TestPC_Class;
     procedure TestPC_ClassForward;
     procedure TestPC_ClassConstructor;
+    procedure TestPC_ClassDispatchMessage;
     procedure TestPC_Initialization;
     procedure TestPC_BoolSwitches;
     procedure TestPC_ClassInterface;
@@ -748,6 +749,8 @@ begin
 
   CheckRestoredReference(Path+'.NewInstanceFunction',Orig.NewInstanceFunction,Rest.NewInstanceFunction);
   AssertEquals(Path+'.GUID',Orig.GUID,Rest.GUID);
+  AssertEquals(Path+'.DispatchField',Orig.DispatchField,Rest.DispatchField);
+  AssertEquals(Path+'.DispatchStrField',Orig.DispatchStrField,Rest.DispatchStrField);
 
   CheckRestoredObject('.Interfaces',Orig.Interfaces,Rest.Interfaces);
   if Orig.Interfaces<>nil then
@@ -2143,6 +2146,38 @@ begin
   WriteReadUnit;
 end;
 
+procedure TTestPrecompile.TestPC_ClassDispatchMessage;
+begin
+  StartUnit(false);
+  Add([
+  'interface',
+  'type',
+  '  {$DispatchField DispInt}',
+  '  {$DispatchStrField DispStr}',
+  '  TObject = class',
+  '  end;',
+  '  THopMsg = record',
+  '    DispInt: longint;',
+  '  end;',
+  '  TPutMsg = record',
+  '    DispStr: string;',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly(var Msg); virtual; abstract; message 2;',
+  '    procedure Run; overload; virtual; abstract;',
+  '    procedure Run(var Msg); overload; message ''Fast'';',
+  '    procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
+  '    procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
+  '  end;',
+  'implementation',
+  'procedure TBird.Run(var Msg);',
+  'begin',
+  'end;',
+  'end.',
+  '']);
+  WriteReadUnit;
+end;
+
 procedure TTestPrecompile.TestPC_Initialization;
 begin
   StartUnit(false);

packages/pastojs/tests/tcmodules.pas

@@ -533,8 +533,9 @@ type
     Procedure TestClass_TObjectFreeFunctionFail;
     Procedure TestClass_TObjectFreePropertyFail;
     Procedure TestClass_ForIn;
-    Procedure TestClass_Message;
+    Procedure TestClass_DispatchMessage;
     Procedure TestClass_Message_DuplicateIntFail;
+    Procedure TestClass_DispatchMessage_WrongFieldNameFail;
 
     // class of
     Procedure TestClassOf_Create;
@@ -1297,9 +1298,12 @@ begin
   aScanner.ReadOnlyModeSwitches:=msAllPas2jsModeSwitchesReadOnly;
   aScanner.CurrentModeSwitches:=OBJFPCModeSwitches*msAllPas2jsModeSwitches+msAllPas2jsModeSwitchesReadOnly;
 
-  aScanner.AllowedBoolSwitches:=msAllPas2jsBoolSwitches;
-  aScanner.ReadOnlyBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly;
-  aScanner.CurrentBoolSwitches:=msAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
+  aScanner.AllowedBoolSwitches:=bsAllPas2jsBoolSwitches;
+  aScanner.ReadOnlyBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly;
+  aScanner.CurrentBoolSwitches:=bsAllPas2jsBoolSwitchesReadOnly+[bsHints,bsNotes,bsWarnings,bsWriteableConst];
+
+  aScanner.AllowedValueSwitches:=vsAllPas2jsValueSwitches;
+  aScanner.ReadOnlyValueSwitches:=vsAllPas2jsValueSwitchesReadOnly;
 
   aScanner.OnLog:=@OnScannerLog;
 
@@ -14419,17 +14423,31 @@ begin
     '']));
 end;
 
-procedure TTestModule.TestClass_Message;
+procedure TTestModule.TestClass_DispatchMessage;
 begin
   StartProgram(false);
   Add([
   'type',
   '  TObject = class',
+  '    {$DispatchField DispInt}',
+  '    procedure Dispatch(var Msg); virtual; abstract;',
+  '    {$DispatchStrField DispStr}',
+  '    procedure DispatchStr(var Msg); virtual; abstract;',
+  '  end;',
+  '  THopMsg = record',
+  '    DispInt: longint;',
+  '  end;',
+  '  TPutMsg = record',
+  '    DispStr: string;',
+  '  end;',
+  '  TBird = class',
   '    procedure Fly(var Msg); virtual; abstract; message 2;',
   '    procedure Run; overload; virtual; abstract;',
   '    procedure Run(var Msg); overload; message ''Fast'';',
+  '    procedure Hop(var Msg: THopMsg); virtual; abstract; message 3;',
+  '    procedure Put(var Msg: TPutMsg); virtual; abstract; message ''foo'';',
   '  end;',
-  'procedure TObject.Run(var Msg);',
+  'procedure TBird.Run(var Msg);',
   'begin',
   'end;',
   'begin',
@@ -14442,13 +14460,37 @@ begin
     '  };',
     '  this.$final = function () {',
     '  };',
+    '});',
+    'rtl.recNewT($mod, "THopMsg", function () {',
+    '  this.DispInt = 0;',
+    '  this.$eq = function (b) {',
+    '    return this.DispInt === b.DispInt;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    this.DispInt = s.DispInt;',
+    '    return this;',
+    '  };',
+    '});',
+    'rtl.recNewT($mod, "TPutMsg", function () {',
+    '  this.DispStr = "";',
+    '  this.$eq = function (b) {',
+    '    return this.DispStr === b.DispStr;',
+    '  };',
+    '  this.$assign = function (s) {',
+    '    this.DispStr = s.DispStr;',
+    '    return this;',
+    '  };',
+    '});',
+    'rtl.createClass($mod, "TBird", $mod.TObject, function () {',
     '  this.Run$1 = function (Msg) {',
     '  };',
     '  this.$msgint = {',
-    '    "2": "Fly"',
+    '    "2": "Fly",',
+    '    "3": "Hop"',
     '  };',
     '  this.$msgstr = {',
-    '    Fast: "Run$1"',
+    '    Fast: "Run$1",',
+    '    foo: "Put"',
     '  };',
     '});',
     '']),
@@ -14471,6 +14513,27 @@ begin
   ConvertProgram;
 end;
 
+procedure TTestModule.TestClass_DispatchMessage_WrongFieldNameFail;
+begin
+  StartProgram(false);
+  Add([
+  'type',
+  '  TObject = class',
+  '    {$dispatchfield Msg}',
+  '    procedure Dispatch(var Msg); virtual; abstract;',
+  '  end;',
+  '  TFlyMsg = record',
+  '    FlyId: longint;',
+  '  end;',
+  '  TBird = class',
+  '    procedure Fly(var Msg: TFlyMsg); virtual; abstract; message 3;',
+  '  end;',
+  'begin',
+  '']);
+  ConvertProgram;
+  CheckHint(mtWarning,nDispatchRequiresX,'Dispatch requires record field "Msg"');
+end;
+
 procedure TTestModule.TestClassOf_Create;
 begin
   StartProgram(false);

rtl/openbsd/i386/cprt0.as

@@ -68,10 +68,15 @@ ___start:
 	subl $16,%esp
 	pushl %esi
 	pushl %ebx
+	call fpc_geteipasecx
+	addl $_GLOBAL_OFFSET_TABLE_,%ecx
+	movl %ecx,%edi
 	movl 12(%ebp),%esi
 	movl 16(%ebp),%eax
-	movl %eax,environ
-	movl %eax,operatingsystem_parameter_envp
+	movl environ@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	movl operatingsystem_parameter_envp@GOT(%edi),%ecx
+	movl %eax,(%ecx)
 	movl (%esi),%ebx
 	testl %ebx,%ebx
 	je .L3
@@ -79,61 +84,76 @@ ___start:
 	pushl $47
 	pushl %ebx
 	call _strrchr
-	movl %eax,__progname
+	movl __progname@GOT(%edi),%ecx
+	movl %eax,(%ecx)
 	addl $16,%esp
 	testl %eax,%eax
 	jne .L4
-	movl %ebx,__progname
+	movl %ebx,(%ecx)
 	jmp .L5
 	.p2align 4,,7
 .L4:
 	incl %eax
-	movl %eax,__progname
+	movl %eax,(%ecx)
 .L5:
-	movl $__progname_storage,%edx
+	movl __progname_storage@GOT(%edi),%edx
 	jmp .L12
 	.p2align 4,,7
 .L9:
 	movb (%eax),%al
 	movb %al,(%edx)
-	incl __progname
+	movl __progname@GOT(%edi),%ecx
+	incl (%ecx)
 	incl %edx
 .L12:
-	movl __progname,%eax
+	movl __progname@GOT(%edi),%ecx
+	movl (%ecx),%eax
 	cmpb $0,(%eax)
 	je .L7
-	cmpl $__progname_storage+255,%edx
+	movl __progname_storage@GOT(%edi),%ecx
+	addl $255,%ecx
+	cmpl %ecx,%edx
 	jb .L9
 .L7:
 	movb $0,(%edx)
-	movl $__progname_storage,__progname
+	pushl %eax
+	movl __progname_storage@GOT(%edi),%eax
+	movl __progname@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	popl %eax
 .L3:
 #	call __init
 	subl $16,%esp
 	pushl %eax
 	movl 8(%ebp),%eax
-	movl %eax,operatingsystem_parameter_argc
-	movl %esi,operatingsystem_parameter_argv
+	movl operatingsystem_parameter_argc@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	movl operatingsystem_parameter_argv@GOT(%edi),%ecx
+	movl %esi,(%ecx)
 	popl %eax
 #	pushl environ
 #	pushl %esi
 #	pushl 8(%ebp)
+	movl ___fpucw@GOT(%edi),%ecx
 	finit
 	fwait
-	fldcw ___fpucw
+	fldcw (%ecx)
 	xorl  %ebp,%ebp
 	call main
 	pushl %eax
-	call exit
+	call exit@PLT
         .p2align 2,0x90
 
 .globl _haltproc
 .type _haltproc,@function
 
 _haltproc:
-           mov $1,%eax
-           movzwl operatingsystem_result,%ebx
+           call fpc_geteipasebx
+           addl $_GLOBAL_OFFSET_TABLE_,%ebx
+           movl operatingsystem_result@GOT(%ebx),%ebx
+           movzwl (%ebx),%ebx
            pushl %ebx
+           mov $1,%eax
            call .Lactualsyscall
            addl  $4,%esp
            jmp   _haltproc

rtl/openbsd/i386/prt0.as

@@ -64,10 +64,15 @@ ___start:
 	subl $16,%esp
 	pushl %esi
 	pushl %ebx
+	call fpc_geteipasecx
+	addl $_GLOBAL_OFFSET_TABLE_,%ecx
+	movl %ecx,%edi
 	movl 12(%ebp),%esi
 	movl 16(%ebp),%eax
-	movl %eax,environ
-	movl %eax,operatingsystem_parameter_envp
+	movl environ@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	movl operatingsystem_parameter_envp@GOT(%edi),%ecx
+	movl %eax,(%ecx)
 	movl (%esi),%ebx
 	testl %ebx,%ebx
 	je .L3
@@ -75,48 +80,60 @@ ___start:
 	pushl $47
 	pushl %ebx
 	call _strrchr
-	movl %eax,__progname
+	movl __progname@GOT(%edi),%ecx
+	movl %eax,(%ecx)
 	addl $16,%esp
 	testl %eax,%eax
 	jne .L4
-	movl %ebx,__progname
+	movl %ebx,(%ecx)
 	jmp .L5
 	.p2align 4,,7
 .L4:
 	incl %eax
-	movl %eax,__progname
+	movl %eax,(%ecx)
 .L5:
-	movl $__progname_storage,%edx
+	movl __progname_storage@GOT(%edi),%edx
 	jmp .L12
 	.p2align 4,,7
 .L9:
 	movb (%eax),%al
 	movb %al,(%edx)
-	incl __progname
+	movl __progname@GOT(%edi),%ecx
+	incl (%ecx)
 	incl %edx
 .L12:
-	movl __progname,%eax
+	movl __progname@GOT(%edi),%ecx
+	movl (%ecx),%eax
 	cmpb $0,(%eax)
 	je .L7
-	cmpl $__progname_storage+255,%edx
+	movl __progname_storage@GOT(%edi),%ecx
+	addl $255,%ecx
+	cmpl %ecx,%edx
 	jb .L9
 .L7:
 	movb $0,(%edx)
-	movl $__progname_storage,__progname
+	pushl %eax
+	movl __progname_storage@GOT(%edi),%eax
+	movl __progname@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	popl %eax
 .L3:
 #	call __init
 	subl $16,%esp
 	pushl %eax
 	movl 8(%ebp),%eax
-	movl %eax,operatingsystem_parameter_argc
-	movl %esi,operatingsystem_parameter_argv
+	movl operatingsystem_parameter_argc@GOT(%edi),%ecx
+	movl %eax,(%ecx)
+	movl operatingsystem_parameter_argv@GOT(%edi),%ecx
+	movl %esi,(%ecx)
 	popl %eax
 #	pushl environ
 #	pushl %esi
 #	pushl 8(%ebp)
+	movl ___fpucw@GOT(%edi),%ecx
 	finit
 	fwait
-	fldcw ___fpucw
+	fldcw (%ecx)
 	xorl  %ebp,%ebp
 	call main
 #	pushl %eax
@@ -128,9 +145,12 @@ ___start:
 .type _haltproc,@function
 
 _haltproc:
-           mov $1,%eax
-           movzwl operatingsystem_result,%ebx
+           call fpc_geteipasebx
+           addl $_GLOBAL_OFFSET_TABLE_,%ebx
+           movl operatingsystem_result@GOT(%ebx),%ebx
+           movzwl (%ebx),%ebx
            pushl %ebx
+           mov $1,%eax
            call .Lactualsyscall
            addl  $4,%esp
            jmp   _haltproc

utils/pas2js/docs/translation.html

@@ -65,7 +65,7 @@
     <a href="#functiontype">Translating function types</a><br>
     <a href="#absolute">Translating var modifier absolute</a><br>
     <a href="#assert">Translating assert()</a><br>
-    <a href="#dispatch">TObject.Dispatch</a><br>
+    <a href="#dispatch">Dispatch messages</a><br>
     <a href="#calljavascript">Calling JavaScript from Pascal</a><br>
     <a href="#asm">The asm block</a><br>
     <a href="#assembler">The procedure modifier assembler</a><br>
@@ -2271,17 +2271,42 @@ End.
     </div>
 
     <div class="section">
-    <h2 id="dispatch">TObject.Dispatch</h2>
-    The procedure modifier '''message''' and the ''TObject.Dispatch'' works
+    <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
-    ''Dispatch'' calls the method with that message number or string.<br>
-    The procedure modifier '''message &lt;integer&gt;''' adds an entry to the
-    ''$msgint'' object, and modifier '''message &lt;string&gt;''' adds an entry
-    to the ''$msgstr'' object.<br>
-    The '''TObject.Dispatch''' expects as argument a record with an integer
-    field ''Msg'' (case sensitive).<br>
-    The '''TObject.DispatchStr''' expects as argument a record with a string
-    field ''MsgStr'' (case sensitive).<br>
+    <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>
+  {$DispatchField Msg} // enable checking message methods for record field name "Msg"
+  {$DispatchStrField MsgStr}
+  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>