mirror of
https://gitlab.com/freepascal.org/fpc/source.git
synced 2025-04-10 05:48:59 +02:00
+ GetProcessID added
This commit is contained in:
Tomas Hajny
parent
e599681e68
commit
353d5cc3de
@ -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.
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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)
|
||||
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
}
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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
|
||||
|
||||
Loading…
Reference in New Issue
Block a user