* Due to TThreads sometimes being used for posting messages to the application event queue, the event queue must be made thread safe. I think this is how it is done. Please test or advise of a better idea - I am new to TThreads.

2 files changed, 63 insertions, 27 deletions

diff --git a/src/corelib/fpg_base.pas b/src/corelib/fpg_base.pas
index 3c408639..37e19471 100644
--- a/src/corelib/fpg_base.pas
+++ b/src/corelib/fpg_base.pas
@@ -24,7 +24,8 @@ interface
 uses
   Classes,
   SysUtils,
-  fpg_impl;
+  fpg_impl,
+  syncobjs; // TCriticalSection usage
 
 type
   TfpgCoord       = integer;     // we might use floating point coordinates in the future...
@@ -456,6 +457,7 @@ type
   private
     FMainForm: TfpgWindowBase;
     FTerminated: boolean;
+    FCritSect: TCriticalSection;
     function    GetForm(Index: Integer): TfpgWindowBase;
     function    GetFormCount: integer;
     function    GetTopModalForm: TfpgWindowBase;
@@ -466,6 +468,7 @@ type
     function    DoGetFontFaceList: TStringList; virtual; abstract;
   public
     constructor Create(const AParams: string); virtual; reintroduce;
+    destructor  Destroy; override;
     function    GetFontFaceList: TStringList;
     procedure   PushModalForm(AForm: TfpgWindowBase);
     procedure   PopModalForm;
@@ -477,6 +480,8 @@ type
     function    Screen_dpi_y: integer; virtual; abstract;
     function    Screen_dpi: integer; virtual; abstract;
     procedure   Terminate;
+    procedure   Lock;
+    procedure   Unlock;
     property    FormCount: integer read GetFormCount;
     property    Forms[Index: Integer]: TfpgWindowBase read GetForm;
     property    IsInitialized: boolean read FIsInitialized;
@@ -2052,6 +2057,13 @@ constructor TfpgApplicationBase.Create(const AParams: string);
 begin
   inherited Create(nil);
   FModalFormStack := TList.Create;
+  FCritSect := TCriticalSection.Create;
+end;
+
+destructor TfpgApplicationBase.Destroy;
+begin
+  FCritSect.Free;
+  inherited Destroy;
 end;
 
 function TfpgApplicationBase.GetFormCount: integer;
@@ -2124,6 +2136,16 @@ begin
   Terminated := True;
 end;
 
+procedure TfpgApplicationBase.Lock;
+begin
+  FCritSect.Enter;
+end;
+
+procedure TfpgApplicationBase.Unlock;
+begin
+  FCritSect.Leave;
+end;
+
 { TfpgClipboardBase }
 
 constructor TfpgClipboardBase.Create;
diff --git a/src/corelib/fpg_msgqueue.inc b/src/corelib/fpg_msgqueue.inc
index aed7f62b..b78eadef 100644
--- a/src/corelib/fpg_msgqueue.inc
+++ b/src/corelib/fpg_msgqueue.inc
@@ -71,11 +71,16 @@ procedure fpgDeleteFirstMessage;
 var
   e: TMessageListElement;
 begin
-  e := UsedFirstMessage;
-  if e <> nil then
-  begin
-    MsgListRemoveElement(e, UsedFirstMessage, UsedLastMessage);
-    MsgListInsertElement(e, FreeFirstMessage, FreeLastMessage);
+  fpgApplication.Lock;
+  try
+    e := UsedFirstMessage;
+    if e <> nil then
+    begin
+      MsgListRemoveElement(e, UsedFirstMessage, UsedLastMessage);
+      MsgListInsertElement(e, FreeFirstMessage, FreeLastMessage);
+    end;
+  finally
+    fpgApplication.Unlock;
   end;
 end;
 
@@ -113,17 +118,21 @@ var
 begin
   if Dest = nil then
     Exit; //==>
-
-  p := fpgAllocateMessage;
-  if p <> nil then
-  begin
-    p^.MsgCode := MsgCode;
-    p^.Sender  := Sender;
-    p^.Dest    := Dest;
-    p^.Params  := aparams;
-  end
-  else
-    Writeln('THE MESSAGE QUEUE IS FULL.');
+  fpgApplication.Lock;
+  try
+    p := fpgAllocateMessage;
+    if p <> nil then
+    begin
+      p^.MsgCode := MsgCode;
+      p^.Sender  := Sender;
+      p^.Dest    := Dest;
+      p^.Params  := aparams;
+    end
+    else
+      Writeln('THE MESSAGE QUEUE IS FULL.');
+  finally
+    fpgApplication.Unlock;
+  end;
 end;
 
 procedure fpgPostMessage(Sender, Dest: TObject; MsgCode: integer); overload;
@@ -133,16 +142,21 @@ begin
   if Dest = nil then
     Exit; //==>
 
-  p := fpgAllocateMessage;
-  if p <> nil then
-  begin
-    p^.MsgCode := MsgCode;
-    p^.Sender  := Sender;
-    p^.Dest    := Dest;
-    p^.Stop    := False;
-  end
-  else
-    Writeln('THE MESSAGE QUEUE IS FULL.');
+  fpgApplication.Lock;
+  try
+    p := fpgAllocateMessage;
+    if p <> nil then
+    begin
+      p^.MsgCode := MsgCode;
+      p^.Sender  := Sender;
+      p^.Dest    := Dest;
+      p^.Stop    := False;
+    end
+    else
+      Writeln('THE MESSAGE QUEUE IS FULL.');
+  finally
+    fpgApplication.Unlock;
+  end;
 end;
 
 procedure fpgSendMessage(Sender, Dest: TObject; MsgCode: integer; var aparams: TfpgMessageParams); overload;