+ GetProcessID added

rtl/atari/system.pas

@@ -63,6 +63,12 @@ const
     {$I lowmath.inc}
 
 
+function GetProcessID:SizeUInt;
+begin
+{$WARNING To be checked by platform maintainer}
+ GetProcessID := 1;
+end;
+
     const
       argc : longint = 0;
 
@@ -766,7 +772,10 @@ end.
 
 {
   $Log$
-  Revision 1.11  2004-09-03 19:25:21  olle
+  Revision 1.12  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.11  2004/09/03 19:25:21  olle
     + added maxExitCode to all System.pp
     * constrained error code to be below maxExitCode in RunError et. al.
 

rtl/beos/system.pp

@@ -495,6 +495,13 @@ begin
 end;
 
 
+function GetProcessID:SizeUInt;
+begin
+{$WARNING To be corrected by platform maintainer}
+ GetProcessID := 1;
+end;
+
+
 {*****************************************************************************
                          SystemUnit Initialization
 *****************************************************************************}
@@ -539,7 +546,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.18  2004-11-04 09:32:31  peter
+  Revision 1.19  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.18  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.17  2004/10/25 15:38:59  peter

rtl/bsd/system.pp

@@ -186,6 +186,10 @@ end;
 {$endif Darwin}
 {$endif FPC_USE_LIBC}
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := SizeUInt (fpGetPID);
+end;
 
 
 Begin
@@ -214,7 +218,10 @@ End.
 
 {
   $Log$
-  Revision 1.20  2004-11-04 09:32:31  peter
+  Revision 1.21  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.20  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.19  2004/07/17 15:31:03  jonas

rtl/emx/system.pas

@@ -114,6 +114,22 @@ var
 (* 4 .. detached (background) OS/2 process *)
   ApplicationType: cardinal;
 
+{$ifdef HASTHREADVAR}
+threadvar
+{$else HASTHREADVAR}
+var
+{$endif HASTHREADVAR}
+(* Thread ID of current thread - stored here    *)
+(* to avoid repeated calls to DosGetInfoBlocks. *)
+  ThreadID: cardinal;
+
+
+procedure SetDefaultOS2FileType (FType: ShortString);
+
+procedure SetDefaultOS2Creator (Creator: ShortString);
+
+
+
 implementation
 
 {$I system.inc}
@@ -128,6 +144,16 @@ var
     BrkLimit: cardinal;
 {$ENDIF CONTHEAP}
 
+
+var
+  ProcessID: SizeUInt;
+
+function GetProcessID:SizeUInt;
+begin
+ GetProcessID := ProcessID;
+end;
+
+
 procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
                             PAPIB: PPProcessInfoBlock); cdecl;
                             external 'DOSCALLS' index 312;
@@ -285,6 +311,7 @@ end {['eax', 'ecx', 'edx']};
 syscall $7f00 resizes the brk area}
 
 function sbrk(size:longint):pointer;
+xxx
 {$IFDEF DUMPGROW}
 var
   L: longword;
@@ -1176,6 +1203,29 @@ begin
 end;
 
 
+{$ifdef HASTHREADVAR}
+threadvar
+{$else HASTHREADVAR}
+var
+{$endif HASTHREADVAR}
+  DefaultCreator: ShortString = '';
+  DefaultFileType: ShortString = '';
+
+
+procedure SetDefaultOS2FileType (FType: ShortString);
+begin
+{$WARNING Not implemented yet!}
+  DefaultFileType := FType;
+end;
+
+
+procedure SetDefaultOS2Creator (Creator: ShortString);
+begin
+{$WARNING Not implemented yet!}
+  DefaultCreator := Creator;
+end;
+
+
 function GetFileHandleCount: longint;
 var L1: longint;
     L2: cardinal;
@@ -1322,7 +1372,10 @@ begin
 end.
 {
   $Log$
-  Revision 1.30  2004-11-04 09:32:31  peter
+  Revision 1.31  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.30  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.29  2004/10/25 15:38:59  peter

rtl/fakertl/system.pp

@@ -31,6 +31,11 @@ begin
 end;
 }
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := 1;
+end;
+
 begin
    b:=4;
    a:=b;
@@ -41,7 +46,10 @@ end.
 
 {
   $Log$
-  Revision 1.4  2002-09-07 16:01:17  peter
+  Revision 1.5  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.4  2002/09/07 16:01:17  peter
     * old logs removed and tabs fixed
 
   Revision 1.3  2002/07/28 20:43:47  florian

rtl/go32v2/system.pp

@@ -48,7 +48,6 @@ const
  DirectorySeparator = '\';
  DriveSeparator = ':';
  PathSeparator = ';';
- ExtensionSeparator = '.';
 { FileNameCaseSensitive is defined separately below!!! }
  maxExitCode = 255;
 
@@ -1603,7 +1602,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.44  2004-11-25 17:37:59  jonas
+  Revision 1.45  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.44  2004/11/25 17:37:59  jonas
     * fixed some C-linking problems (the C-prefix is now always added to
       cdecl external functions, also if you define the name explicitly)
 

rtl/inc/system.inc

@@ -567,6 +567,12 @@ Begin
   InOutRes:=0;
 End;
 
+Function GetThreadID:SizeUInt;{$ifdef SYSTEMINLINE}inline;{$endif}
+begin
+(* ThreadID is stored in a threadvar and made available in interface *)
+(* to allow setup of this value during thread initialization.        *)
+  GetThreadID := ThreadID;
+end;
 
 {*****************************************************************************
                          Stack check code
@@ -999,7 +1005,10 @@ end;
 
 {
   $Log$
-  Revision 1.70  2004-11-21 16:14:59  jonas
+  Revision 1.71  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.70  2004/11/21 16:14:59  jonas
     * fixed remaining compilation problems
 
   Revision 1.69  2004/11/20 15:49:21  jonas

rtl/inc/systemh.inc

@@ -334,7 +334,6 @@ const
   fmOutput = $D7B2;
   fmInOut  = $D7B3;
   fmAppend = $D7B4;
-  ProcessID: SizeUInt = 1;
   Filemode : byte = 2;
   CmdLine : PChar = nil;
 (* Value should be changed during system initialization as appropriate. *)
@@ -707,6 +706,8 @@ function get_caller_frame(framebp:pointer):pointer;{$ifdef SYSTEMINLINE}inline;{
 
 Function IOResult:Word;{$ifdef SYSTEMINLINE}inline;{$endif}
 Function Sptr:Pointer;{$ifdef SYSTEMINLINE}inline;{$endif}{$ifdef INTERNCONSTINTF}[internconst:fpc_in_const_ptr];{$endif}
+Function GetProcessID:SizeUInt;
+Function GetThreadID:SizeUInt;
 
 
 {*****************************************************************************
@@ -795,7 +796,10 @@ const
 
 {
   $Log$
-  Revision 1.110  2004-11-26 22:26:30  peter
+  Revision 1.111  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.110  2004/11/26 22:26:30  peter
     * internconst for ptr()
 
   Revision 1.109  2004/11/22 22:48:10  michael

rtl/linux/system.pp

@@ -157,6 +157,11 @@ begin
      execpathstr[0]:=char(i);
 end;
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := SizeUInt (fpGetPID);
+end;
+
 
 Begin
   IsConsole := TRUE;
@@ -185,7 +190,10 @@ End.
 
 {
   $Log$
-  Revision 1.19  2004-11-04 09:32:31  peter
+  Revision 1.20  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.19  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.18  2004/07/09 22:31:22  peter

rtl/macos/system.pp

@@ -1112,6 +1112,13 @@ begin
   {$endif }
 end;
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := 1;
+{$WARNING To be implemented - using GetProcessInformation???}
+end;
+
+
 var
   resHdl: Mac_Handle;
   isFolder, hadAlias, leafIsAlias: Boolean;
@@ -1200,7 +1207,10 @@ end.
 
 {
   $Log$
-  Revision 1.25  2004-11-04 09:32:31  peter
+  Revision 1.26  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.25  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.24  2004/10/25 15:38:59  peter

rtl/morphos/system.pp

@@ -823,6 +823,12 @@ begin
   // OpenStdIO(ErrOutput,fmOutput,StdErrorHandle);
 end;
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := 1;
+{$WARNING Implementation of GetProcessID missing!}
+end;
+
 
 begin
   IsConsole := TRUE;
@@ -856,7 +862,10 @@ end.
 
 {
   $Log$
-  Revision 1.22  2004-11-15 23:18:16  karoly
+  Revision 1.23  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.22  2004/11/15 23:18:16  karoly
    * Reworked path handling to be less messy
 
   Revision 1.21  2004/11/04 09:32:31  peter

rtl/netware/system.pp

@@ -929,6 +929,12 @@ begin
   {$endif}
 end;
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := SizeUInt (CurrentProcess);
+{$WARNING GetProcessID implementation should be checked!}
+end;
+
 
 {*****************************************************************************
                          SystemUnit Initialization
@@ -979,7 +985,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.31  2004-11-25 12:32:08  armin
+  Revision 1.32  2004-12-05 14:36:37  hajny
+    + GetProcessID added
+
+  Revision 1.31  2004/11/25 12:32:08  armin
   * adapted to new compiler check for externals
 
   Revision 1.30  2004/11/04 09:32:31  peter

rtl/netwlibc/system.pp

@@ -1009,6 +1009,13 @@ end;
 {$endif}
 
 
+function GetProcessID: SizeUInt;
+begin
+{$WARNING GetProcessID implementation missing}
+ GetProcessID := 1;
+end;
+
+
 { this will be called if the nlm is unloaded. It will NOT be
   called if the program exits i.e. with halt.
   Halt (or _exit) can not be called from this callback procedure }
@@ -1184,7 +1191,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.8  2004-11-25 12:38:17  armin
+  Revision 1.9  2004-12-05 14:36:38  hajny
+    + GetProcessID added
+
+  Revision 1.8  2004/11/25 12:38:17  armin
   * adapted to new compiler check for externals
 
   Revision 1.7  2004/11/04 09:32:31  peter

rtl/os2/system.pas

@@ -122,6 +122,7 @@ var
 (* Pointer to the block of environment variables - used e.g. in unit Dos. *)
   Environment: PChar;
 
+
 var
 (* Type / run mode of the current process: *)
 (* 0 .. full screen OS/2 session           *)
@@ -131,10 +132,32 @@ var
 (* 4 .. detached (background) OS/2 process *)
   ApplicationType: cardinal;
 
+(* Is allocation of memory above 512 MB address limit allowed? Initialized *)
+(* during initialization of system unit according to capabilities of the   *)
+(* underlying OS/2 version, can be overridden by user - heap is allocated  *)
+(* for all threads, so the setting isn't declared as a threadvar and       *)
+(* should be only changed at the beginning of the main thread if needed.   *)
+  UseHighMem: boolean;
+
+
+
+procedure SetDefaultOS2FileType (FType: ShortString);
+
+procedure SetDefaultOS2Creator (Creator: ShortString);
+
+
+
 implementation
 
 {$I system.inc}
 
+var
+  ProcessID: SizeUInt;
+
+function GetProcessID:SizeUInt;
+begin
+ GetProcessID := ProcessID;
+end;
 
 procedure DosGetInfoBlocks (PATIB: PPThreadInfoBlock;
                             PAPIB: PPProcessInfoBlock); cdecl;
@@ -486,47 +509,74 @@ external 'DOSCALLS' index 305;
 function DosFreeMem (P: pointer): cardinal; cdecl;
 external 'DOSCALLS' index 304;
 
-var
-  HighMemSupported: boolean;
-  Int_Heap : Pointer;
-  Int_heapSize : longint;
-
 {$IFDEF DUMPGROW}
  {$DEFINE EXTDUMPGROW}
 {$ENDIF DUMPGROW}
 
+{$IFDEF EXTDUMPGROW}
+var
+  Int_HeapSize: cardinal;
+{$ENDIF EXTDUMPGROW}
+
+{function GetHeapSize: longint; assembler;
+asm
+  movl Int_HeapSize, %eax
+end ['EAX'];
+}
+
+
 function SysOSAlloc (Size: PtrInt): pointer;
 var
   P: pointer;
   RC: cardinal;
 begin
 {$IFDEF EXTDUMPGROW}
-  WriteLn ('Trying to grow heap by ', Size);
+  if Int_HeapSize <> high (cardinal) then
+{
+  if Int_HeapSize = high (cardinal) then
+   WriteLn ('Trying to allocate first heap of size ', Size)
+  else
+}
+   WriteLn ('Trying to grow heap by ', Size, ' to ', Int_HeapSize);
 {$ENDIF}
 
-  if HighMemSupported then
+  if UseHighMem then
    RC := DosAllocMem (P, Size, $403)
   else
    RC := DosAllocMem (P, Size, 3);
   if RC = 0 then
    begin
 {$IFDEF EXTDUMPGROW}
+  if Int_HeapSize <> high (cardinal) then
     WriteLn ('DosAllocMem returned memory at ', cardinal (P));
 {$ENDIF}
     RC := DosSetMem (P, Size, $410);
     if RC = 0 then
      begin
 {$IFDEF EXTDUMPGROW}
-      WriteLn ('New heap at ', cardinal (P));
+      if Int_HeapSize <> high (cardinal) then
+       WriteLn ('New heap at ', cardinal (P));
 {$ENDIF EXTDUMPGROW}
       SysOSAlloc := P;
-      Inc (Int_HeapSize, Size);
+{$IFDEF EXTDUMPGROW}
+      if Int_HeapSize = high (cardinal) then
+       Int_HeapSize := Size
+      else
+       Inc (Int_HeapSize, Size);
+{$ENDIF EXTDUMPGROW}
      end
     else
      begin
 {$IFDEF EXTDUMPGROW}
-      WriteLn ('Error ', RC, ' in DosSetMem while trying to commit memory!');
-      WriteLn ('Total allocated memory is ', Int_HeapSize);
+      if Int_HeapSize <> high (cardinal) then
+       begin
+        WriteLn ('Error ', RC, ' in DosSetMem while trying to commit memory!');
+{      if Int_HeapSize = high (cardinal) then
+        WriteLn ('No allocated memory comitted yet!')
+       else
+}
+        WriteLn ('Total allocated memory is ', Int_HeapSize);
+       end;
 {$ENDIF EXTDUMPGROW}
       RC := DosFreeMem (P);
       SysOSAlloc := nil;
@@ -536,8 +586,15 @@ begin
    begin
     SysOSAlloc := nil;
 {$IFDEF EXTDUMPGROW}
-    WriteLn ('Error ', RC, ' during additional memory allocation (DosAllocMem)!');
-    WriteLn ('Total allocated memory is ', Int_HeapSize);
+    if Int_HeapSize <> high (cardinal) then
+     begin
+      WriteLn ('Error ', RC, ' during additional memory allocation (DosAllocMem)!');
+{     if Int_HeapSize = high (cardinal) then
+       WriteLn ('No memory allocated yet!')
+      else
+}
+      WriteLn ('Total allocated memory is ', Int_HeapSize);
+     end;
 {$ENDIF EXTDUMPGROW}
    end;
 end;
@@ -551,8 +608,8 @@ begin
 {$IFDEF EXTDUMPGROW}
   WriteLn ('Trying to free memory!');
   WriteLn ('Total allocated memory is ', Int_HeapSize);
-{$ENDIF EXTDUMPGROW}
   Dec (Int_HeapSize, Size);
+{$ENDIF EXTDUMPGROW}
   RC := DosSetMem (P, Size, $20);
   if RC = 0 then
    begin
@@ -1195,6 +1252,29 @@ asm
 end;
 
 
+{$ifdef HASTHREADVAR}
+threadvar
+{$else HASTHREADVAR}
+var
+{$endif HASTHREADVAR}
+  DefaultCreator: ShortString;
+  DefaultFileType: ShortString;
+
+
+procedure SetDefaultOS2FileType (FType: ShortString);
+begin
+{$WARNING Not implemented yet!}
+  DefaultFileType := FType;
+end;
+
+
+procedure SetDefaultOS2Creator (Creator: ShortString);
+begin
+{$WARNING Not implemented yet!}
+  DefaultCreator := Creator;
+end;
+
+
 procedure InitEnvironment;
 var env_count : longint;
     dos_env,cp : pchar;
@@ -1438,6 +1518,7 @@ var TIB: PThreadInfoBlock;
     PIB: PProcessInfoBlock;
     RC: cardinal;
     ErrStr: string;
+    P: pointer;
 
 begin
     IsLibrary := FALSE;
@@ -1453,52 +1534,26 @@ begin
     ThreadID := TIB^.TIB2^.TID;
     IsConsole := ApplicationType <> 3;
 
-    exitproc:=nil;
+    ExitProc := nil;
 
     {Initialize the heap.}
-    // Logic is following:
-    //   Application allocates the amount of memory specified by the compiler
-    //   switch -Ch but without commiting. On heap growing required amount of
-    //   memory commited. More memory is allocated as needed within sbrk.
-(* Being changed now - new behaviour will be documented after  *)
-(* things settle down a bit and everything is tested properly. *)
-
-    RC := DosAllocMem (Int_Heap, Int_HeapSize, $403);
-    if RC = 87 then
-     begin
-(* Using of high memory address space (> 512 MB) *)
-(* is not supported on this system.              *)
-      RC := DosAllocMem (Int_Heap, Int_HeapSize, 3);
-      HighMemSupported := false;
-     end
-    else
-     HighMemSupported := true;
-    if RC <> 0 then
-     begin
-      Str (RC, ErrStr);
-      ErrStr := 'Error during heap initialization (DosAllocMem - ' + ErrStr + ')!!'#13#10;
-      DosWrite (2, @ErrStr [1], Length (ErrStr), RC);
-      HandleError (204);
-     end
-    else
-     begin
-      RC := DosSetMem (Int_Heap, Int_HeapSize, $410);
-      if RC <> 0 then
-       begin
-        Str (RC, ErrStr);
-        ErrStr := 'Error during heap initialization (DosSetMem - ' + ErrStr + ')!!'#13#10;
-        DosWrite (2, @ErrStr [1], Length (ErrStr), RC);
-        HandleError (204);
-       end
-{$IFDEF EXTDUMPGROW}
-      else
-       begin
-        Str (Int_HeapSize, ErrStr);
-        ErrStr := 'Initially allocated ' + ErrStr + ' bytes of memory.'#13#10;
-        DosWrite (1, @ErrStr [1], Length (ErrStr), RC);
-       end
-{$ENDIF}
-     end;
+    (* Logic is following:
+       The heap is initially restricted to low address space (< 512 MB).
+       If underlying OS/2 version allows using more than 512 MB per process
+       (OS/2 WarpServer for e-Business, eComStation, possibly OS/2 Warp 4.0
+       with FP13 and above as well), use of this high memory is allowed for
+       future memory allocations at the end of System unit initialization.
+       The consequences are that the compiled application can allocate more
+       memory, but it must make sure to use direct DosAllocMem calls if it
+       needs a memory block for some system API not supporting high memory.
+       This is probably no problem for direct calls to these APIs, but
+       there might be situations when a memory block needs to be passed
+       to a 3rd party DLL which in turn calls such an API call. In case
+       of problems usage of high memory can be turned off by setting
+       UseHighMem to false - the program should change the setting at its
+       very beginning (e.g. in initialization section of the first unit
+       listed in the "uses" section) to avoid having preallocated memory
+       from the high memory region before changing value of this variable. *)
     InitHeap;
 
     { ... and exceptions }
@@ -1516,18 +1571,42 @@ begin
 
     CmdLine := pointer (PIB^.Cmd);
     InitArguments;
+    DefaultCreator := '';
+    DefaultFileType := '';
 
 {$ifdef HASVARIANT}
     initvariantmanager;
 {$endif HASVARIANT}
 
-{$IFDEF DUMPGROW}
-    WriteLn ('Initial brk size is ', GetHeapSize);
-{$ENDIF DUMPGROW}
+{$IFDEF EXTDUMPGROW}
+{    Int_HeapSize := high (cardinal);}
+{$ENDIF EXTDUMPGROW}
+    RC := DosAllocMem (P, 4096, $403);
+    if RC = 87 then
+(* Using of high memory address space (> 512 MB) *)
+(* is not supported on this system.              *)
+     UseHighMem := false
+    else
+     begin
+      UseHighMem := true;
+      if RC <> 0 then
+       begin
+        Str (RC, ErrStr);
+        ErrStr := 'Error during heap initialization (DosAllocMem - ' + ErrStr + ')!!'#13#10;
+        DosWrite (2, @ErrStr [1], Length (ErrStr), RC);
+        HandleError (204);
+       end
+      else
+       DosFreeMem (P);
+     end;
+
 end.
 {
   $Log$
-  Revision 1.76  2004-11-04 09:32:31  peter
+  Revision 1.77  2004-12-05 14:36:38  hajny
+    + GetProcessID added
+
+  Revision 1.76  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.75  2004/10/25 15:38:59  peter

rtl/sunos/system.pp

@@ -91,6 +91,12 @@ begin
 end;
 
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := SizeUInt (fpGetPID);
+end;
+
+
 procedure pascalmain; external name 'PASCALMAIN';
 
 { Main entry point in C style, needed to capture program parameters. }
@@ -130,6 +136,9 @@ End.
 
 {
  $Log$
- Revision 1.2  2004-11-06 22:22:28  florian
+ Revision 1.3  2004-12-05 14:36:38  hajny
+   + GetProcessID added
+
+ Revision 1.2  2004/11/06 22:22:28  florian
    * some sunos stuff from 1.0.x merged
 }

rtl/template/system.pp

@@ -74,6 +74,10 @@ procedure setup_environment;
 begin
 end;
 
+function GetProcessID: SizeUInt;
+begin
+end;
+
 {*****************************************************************************
                          System Dependent Exit code
 *****************************************************************************}
@@ -287,7 +291,10 @@ Begin
 End.
 {
   $Log$
-  Revision 1.14  2004-11-04 09:32:31  peter
+  Revision 1.15  2004-12-05 14:36:38  hajny
+    + GetProcessID added
+
+  Revision 1.14  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.13  2004/10/25 15:38:59  peter

rtl/watcom/system.pp

@@ -1277,7 +1277,7 @@ begin
    end;
 end;
 
-function do_isdevice(handle:longint):boolean;
+function do_isdevice(handle:THandle):boolean;
 var
   regs : trealregs;
 begin
@@ -1486,6 +1486,12 @@ begin
 end;
 
 
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := 1;
+end;
+
+
 var
   temp_int : tseginfo;
 Begin
@@ -1532,7 +1538,10 @@ End.
 
 {
   $Log$
-  Revision 1.17  2004-11-04 09:32:31  peter
+  Revision 1.18  2004-12-05 14:36:38  hajny
+    + GetProcessID added
+
+  Revision 1.17  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.16  2004/10/25 15:38:59  peter

rtl/win32/system.pp

@@ -692,8 +692,11 @@ end;
    function GetCommandLine : pchar;
      stdcall;external 'kernel32' name 'GetCommandLineA';
 
-   function GetCurrentThread : dword;
-     stdcall; external 'kernel32' name 'GetCurrentThread';
+  function GetCurrentProcessId:DWORD;
+    stdcall; external 'kernel32' name 'GetCurrentProcessId';
+ 
+  function GetCurrentThreadId:DWORD;
+    stdcall; external 'kernel32' name 'GetCurrentThreadId';
 
 
 var
@@ -1573,6 +1576,16 @@ begin
    end;
 end;
 
+(* ProcessID cached to avoid repeated calls to GetCurrentProcess. *)
+
+var
+  ProcessID: SizeUInt;
+
+function GetProcessID: SizeUInt;
+begin
+ GetProcessID := ProcessID;
+end;
+
 
 const
    Exe_entry_code : pointer = @Exe_entry;
@@ -1597,8 +1610,8 @@ begin
   setup_arguments;
   { Reset IO Error }
   InOutRes:=0;
-  ProcessID := GetCurrentProcess;
-  ThreadID := GetCurrentThread;
+  ProcessID := GetCurrentProcessID;
+  ThreadID := GetCurrentThreadID;
   { Reset internal error variable }
   errno:=0;
 {$ifdef HASVARIANT}
@@ -1608,7 +1621,10 @@ end.
 
 {
   $Log$
-  Revision 1.63  2004-11-04 09:32:31  peter
+  Revision 1.64  2004-12-05 14:36:38  hajny
+    + GetProcessID added
+
+  Revision 1.63  2004/11/04 09:32:31  peter
   ErrOutput added
 
   Revision 1.62  2004/10/25 15:38:59  peter