+ Two new windows DLL tests added

git-svn-id: trunk@17783 -

.gitattributes

@@ -9634,6 +9634,10 @@ tests/test/cg/variants/tvarol96.pp svneol=native#text/plain
 tests/test/dumpclass.pp svneol=native#text/plain
 tests/test/dumpmethods.pp svneol=native#text/plain
 tests/test/lcpref.inc svneol=native#text/plain
+tests/test/library/tdllexe.pp svneol=native#text/plain
+tests/test/library/tdlltest.pp svneol=native#text/plain
+tests/test/library/testdll.pp svneol=native#text/plain
+tests/test/library/testdll2.pp svneol=native#text/plain
 tests/test/library/tlib1a.pp svneol=native#text/plain
 tests/test/library/tlib1a2.pp svneol=native#text/plain
 tests/test/library/tlib1b.pp svneol=native#text/plain

tests/test/library/tdllexe.pp

@@ -0,0 +1,45 @@
+{
+  Copyright (c) 1998 by Pierre Muller
+
+  Win32 DLL usage example. It needs testdll.pp
+}
+program tdllexe;
+
+uses
+  Windows;
+
+procedure test; external 'testdll2' name 'test';
+function GetString : string; external 'testdll2' name 'GetString';
+
+var
+   s : string;external 'testdll2' name 'teststr';
+const
+  called : boolean = false;
+
+procedure TestExeProc;export;
+begin
+  Writeln('Main: TestExeProc');
+  Writeln('Main: S is: "',s,'"');
+  called:=true;
+end;
+
+exports
+  TestExeProc;
+
+begin
+  s:='Before test call';
+  Writeln('Main: S is: "',GetString,'"');
+  if (s<>GetString) then
+    begin
+      Writeln('Error in DLL variable handling');
+      halt(1);
+    end;
+  test;
+  Writeln('Main: S value after call is: "',s,'"');
+  if not called then
+    begin
+      Writeln('Error in DLL variable handling');
+      halt(1);
+    end;
+
+end.

tests/test/library/tdlltest.pp

@@ -0,0 +1,91 @@
+{
+  Copyright (c) 1998 by Pierre Muller
+
+  Win32 DLL usage example. It needs testdll.pp
+}
+program tdlltest;
+
+uses
+  Windows;
+
+procedure p1(var S : string);
+ external 'testdll' name 'P1';
+procedure proc2(x:longint);
+ external 'testdll' name 'Proc2';
+function GetTestStr : string;
+ external 'testdll' name 'GetTestStr';
+
+
+const
+  GlobalThreadIndex : longint = 0;
+  ThreadCount = 8;
+  StackSize = $100000;
+
+function ThreadMain (Param : pointer) : DWord; stdcall;
+
+var
+  ThreadIndex : longint;
+begin
+  ThreadMain:=0;
+  ThreadIndex:=InterlockedIncrement(GlobalThreadIndex);
+  Writeln('Main: Starting new thread ',hexstr(PtrUint(Param),2*sizeof(pointer)),' ',ThreadIndex);
+  Writeln('Main: Thread Id=',GetCurrentTHreadID);
+  Proc2(GlobalThreadIndex);
+  Sleep (3000);
+  Write('Main: Finishing thread ',ThreadIndex);
+  Writeln(' Thread Id=',GetCurrentTHreadID);
+  InterlockedDecrement(GlobalThreadIndex);
+end;
+
+procedure LaunchThreads;
+var
+  i : longint;
+  ThreadResult : Handle;
+  _threadid : DWord;
+begin
+  for i:=1 to ThreadCount do
+    begin
+      ThreadResult:=CreateThread(nil,stacksize,@ThreadMain,
+                        @GlobalThreadIndex,0,_threadid);
+    end;
+end;
+
+
+var
+   s : string;external 'testdll' name 'FPC_string';
+   s2 : string;
+
+
+   procedure MyMainHook(DllParma : longint);
+   begin
+     Writeln('Main: Thread Detach Hook  called with DLLParam=',DllParam);
+   end;
+
+begin
+  Dll_Thread_Detach_Hook:=@MyMainHook;
+  writeln('Main: Hello!');
+  s2:='Test before';
+  p1(s2);
+  if s2<>'New value' then
+    begin
+      Writeln('Main: Error while calling P1');
+      Halt(1);
+    end;
+  writeln('Main: ',Hinstance,' ',Hprevinst);
+  writeln('Main: testdll s string = ',s);
+  s:='Changed by program';
+  if GetTestStr<>'Changed by program' then
+    begin
+      Writeln('Error in DLL variable handling');
+      Halt(1);
+    end;
+
+  proc2(1234);
+  LaunchThreads;
+  Sleep(2000);
+  While GlobalThreadIndex>0 do
+    begin
+      Writeln('Main: Waiting for threads to finish');
+      Sleep(2000);
+    end;
+end.

tests/test/library/testdll.pp

@@ -0,0 +1,94 @@
+{ %target=win32,win64 }
+{ %needlibrary }
+{
+  Copyright (c) 1998 by Pierre Muller
+
+  Win32 DLL test with threads.
+}
+library testdll;
+
+function GetModuleFileName(hModule:longint;lpszPath:pchar;cchPath:longint):longint;
+  stdcall; external 'kernel32' name 'GetModuleFileNameA';
+procedure beep(ID:longint);
+  stdcall; external 'user32' name 'MessageBeep';
+
+
+var
+  teststr : string;
+
+var
+  global_count : longint;
+threadvar
+  thread_local_count : longint{ = 6};
+
+procedure P1(var s:string);export;
+var
+  i : longint;
+  p:array[0..255] of char;
+begin
+  i:=length(s);
+  getmodulefilename(Hinstance,@p,255);
+  writeln('DLL: Hello, I''m DLL ',pchar(@p));
+  writeln('DLL: S before is "',s,'"');
+  s:='New value';
+end;
+
+procedure P2(x:longint);export;
+begin
+  writeln('DLL: Argument X=',x);
+  writeln('DLL: New teststr="',teststr,'"');
+  inc(global_count);
+  inc(thread_local_count);
+  Writeln('DLL: Thread Id is ',GetCurrentThreadId);
+  Writeln('DLL: Global count=',Global_count);
+  Writeln('DLL: Thread local count=',thread_local_count);
+end;
+
+procedure P3(var t);export;
+var
+  p : pointer;
+begin
+  p:=Addr(T);
+  p:=p;
+end;
+
+procedure P4(x1:pointer);export;
+begin
+  Inc(x1);
+end;
+
+function GetTestStr : string; export;
+begin
+  GetTestStr:=teststr;
+end;
+
+
+procedure MyDllHook(DllParma : longint);
+begin
+  Writeln('DLL: Thread Detach Hook  called with DLLParam=',DllParam);
+  Writeln('DLL: Thread Id is ',GetCurrentThreadId);
+end;
+
+procedure NewExit;
+begin
+  beep(0);
+  writeln('DLL: Exit from testdll');
+  Writeln('DLL: Thread Id is ',GetCurrentThreadId);
+end;
+
+exports
+ P1 index 1,
+ P2 name 'Proc2',
+ P3,
+ GetTestStr,
+ P4 resident,
+ teststr name 'FPC_string';
+
+
+begin
+  Dll_Thread_Detach_Hook:=@MyDllHook;
+  Writeln('DLL: Startup Thread Id is ',GetCurrentThreadId);
+  writeln('DLL: HInstance ',Hinstance,'  PrevInst ',Hprevinst,'  DLLReason ',DLLreason,'  DLLParam ',DLLparam);
+  teststr:='DLL init done';
+  exitproc:=@newExit;
+end.

tests/test/library/testdll2.pp

@@ -0,0 +1,39 @@
+{ %target=win32,win64 }
+{ %needlibrary }
+{
+  Copyright (c) 1998 by Pierre Muller
+
+  Windows DLL test.
+  Check main executable EXPORT support.
+}
+library testdll2;
+
+
+{ This library cannot be called from any other program
+  as it loads EXE exported symbols }
+
+procedure TestExeProc; external 'tdllexe.exe' name 'TestExeProc';
+
+
+var
+  teststr : string;
+
+procedure test;export;
+begin
+  writeln('DLL: Hello, I''m testdll2 DLL');
+  teststr:='In test';
+  TestExeProc;
+  teststr:='After test';
+end;
+
+function GetString : string; export;
+begin
+  GetString := teststr;
+end;
+
+exports
+ test,
+ teststr,
+ GetString;
+
+end.