1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
|
{
This file is part of the Free Pascal run time library.
Copyright (c) 2001-2014 by Free Pascal development team
This file implements heap management for OS/2.
See the file COPYING.FPC, included in this distribution,
for details about the copyright.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
**********************************************************************}
{****************************************************************************
Heap management releated routines.
****************************************************************************}
{Get some memory.
P = Pointer to memory will be returned here.
Size = Number of bytes to get. The size is rounded up to a multiple
of 4096. This is probably not the case on non-intel 386
versions of OS/2.
Flags = One or more of the mfXXXX constants.}
function DosAllocMem(var P:pointer;Size,Flag:cardinal): cardinal; cdecl;
external 'DOSCALLS' index 299;
function DosSetMem(P:pointer;Size,Flag:cardinal): cardinal; cdecl;
external 'DOSCALLS' index 305;
function DosFreeMem (P: pointer): cardinal; cdecl;
external 'DOSCALLS' index 304;
{$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: ptruint): pointer;
var
P: pointer;
RC: cardinal;
begin
{$IFDEF EXTDUMPGROW}
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}
RC := DosAllocMem (P, Size, HeapAllocFlags);
if RC = 0 then
begin
{$IFDEF EXTDUMPGROW}
if Int_HeapSize <> high (cardinal) then
WriteLn ('DosAllocMem returned memory at ', cardinal (P));
{$ENDIF}
SysOSAlloc := P;
{$IFDEF EXTDUMPGROW}
if Int_HeapSize = high (cardinal) then
Int_HeapSize := Size
else
Inc (Int_HeapSize, Size);
{$ENDIF EXTDUMPGROW}
end
else
begin
SysOSAlloc := nil;
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW}
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;
{$define HAS_SYSOSFREE}
procedure SysOSFree (P: pointer; Size: ptruint);
var
RC: cardinal;
begin
{$IFDEF EXTDUMPGROW}
WriteLn ('Trying to free memory!');
WriteLn ('Total allocated memory is ', Int_HeapSize);
Dec (Int_HeapSize, Size);
{$ENDIF EXTDUMPGROW}
RC := DosFreeMem (P);
if RC <> 0 then
begin
OSErrorWatch (RC);
{$IFDEF EXTDUMPGROW}
WriteLn ('Error ', RC, ' during memory deallocation (DosFreeMem)!');
WriteLn ('Total allocated memory is ', Int_HeapSize);
{$ENDIF EXTDUMPGROW}
end;
end;
function ReadUseHighMem: boolean;
begin
ReadUseHighMem := HeapAllocFlags and $400 = $400;
end;
procedure WriteUseHighMem (B: boolean);
begin
if B then
HeapAllocFlags := HeapAllocFlags or $400
else
HeapAllocFlags := HeapAllocFlags and not ($400);
end;
|
